use strict ;
use warnings ;

use constant MAX_RECORD => 256 * 1024 ;

my $DCD = dcd_open("skata3") ;

my $data = '' ;
my $rc   = 0 ;
my $rec  = 0 ;
while ($rc = dcd_read($DCD, $data)) {
  (my $chars = $data) =~ s/[\x00-\x1F\x7F-\xFF]{2,}/~~/g ;
  $chars =~ s/[\x00-\x1F\x7F-\xFF]/~/g ;
  printf "%6d: '%s'\n", $rec++, join("'\n        '", $chars =~ m/(.{1,
+64})/g) ; 
  numbers($data) ;
} ; 

if (!defined($rc)) { print "failed $@\n" ; } ;

sub numbers {
  my ($data) = @_ ;

  my $prev = 0 ;
  my $off  = 0 ;
  my $have = length($data) ;

  my $line = '' ;

  while ($have >= 4) {
    if (substr($data, $off, 4) !~ m/[\x20-\x7E]{4}/) {
      if (!$line) { $line = ' ' x 7 ; } ;
      my $i = unpack("\@${off}V", $data) ;
      if ($prev != $off) { $line .= " #". ($off - $prev) ; } ;
      $line .= sprintf(" 0x%X", $i) ;
      if (($i > 0x00FFFFFF) && ($i < 0xFF000000)) {
        my $f = unpack("\@${off}f<", $data) ;
        $line .= sprintf("(%.6g)", $f) ;
      } ;
      $prev = $off + 4 ;
      if (length($line) > 64) { print $line, "\n" ; $line = '' ; } ;
    } ;
    $off  += 4 ;
    $have -= 4 ;
  } ;

  if ($prev != $off) {
    if (!$line) { $line = ' ' x 7 ; } ;
    $line .= " #". ($off - $prev) ;
  } ;

  if ($line) { print $line, "\n" ; } ;
} ;

#=====================================================================
+====================
# dcd_open: open given 'dcd' file and prepare to read records.
#
# Requires: $name   -- name of file to ppen
#
# Returns:  $DCD    -- skata file "object"

sub dcd_open {
  my ($name) = @_ ;

  open my $FH, '<:raw', $name   or die "could not open $name: $!" ;

  my $f_offset = 0 ;
  my $b_offset = 0 ;
  my $buffer   = '' ;
  my $eof_met  = 0 ;

  my $DCD = [] ;
  @$DCD = ($FH, \$buffer, $f_offset, $b_offset, $eof_met, $name) ;

  return $DCD ;
} ;

#=====================================================================
+====================
# dcd_read: read record from given 'skata' file.
#
# Requires: $SK     -- skata file "object"
#           $rec    -- where to read record into  -- UPDATED IN PLACE
#
# Returns:  > 0     -- OK, record length + 1
#           = 0     -- OK, eof
#         undef     -- failed -- see $@

sub dcd_read {
  my ($DCD, undef) = @_ ;

  my ($FH, $r_buffer, $f_offset, $b_offset, $eof_met, $name) = @$DCD ;

  my $have = length($$r_buffer) - $b_offset ;
  if (($have < (MAX_RECORD + 8)) && !$eof_met) {
    substr($$r_buffer, 0, $b_offset) = '' ;
    my $rc = read $FH, $$r_buffer, (MAX_RECORD * 2) - $have, $have ;
    if (!defined($rc)) { $@ = "failed while reading $!" ; goto FAILED 
+; } ;
    $eof_met  = ($rc == 0) ;
    $have     = length($$r_buffer) ;
    $b_offset = 0 ;
  } ;

  if ($have < 4) {
    if ($have == 0) { return 0 ; } ;       # eof
    $@ = "Attempt to read when only $have bytes available" ;
    goto FAILED ;
  } ;

  my $len = unpack("\@${b_offset}V", $$r_buffer) ;
  if (($len + 8) > $have) {
    if ($len > MAX_RECORD) { $@ = "Record length $len > MAX_RECORD(".M
+AX_RECORD.")" ; }
                      else { $@ = "Record length $len > rest of file $
+have" ;
                             if (!$eof_met) { $@ .= " **BUT NOT AT EOF
+**" ; } ;       } ;
    goto FAILED ;
  } ;

  my $nel ;
  ($_[1], $nel) = unpack("\@${b_offset}V/a*V", $$r_buffer) ;

  if ($nel != $len) {
    $@ = "Start record length $len != end record length $nel" ;
    goto FAILED ;
  } ;

  $b_offset += $len + 8 ;
  $f_offset += $len + 8 ;

  @$DCD = ($FH, $r_buffer, $f_offset, $b_offset, $eof_met, $name) ;

  return $len+1 ;

FAILED:
  $@ .= sprintf(" (\@0x%X of file '%s')", $f_offset, $name) ;
  return undef ;
} ;
[download]