/* --------------------------------------------------------------- */
/* thex -- hex-dump a file to screen or to a file                  */
/* --------------------------------------------------------------- */
/*                                                                 */
/* Copyright (c) Mike Cowlishaw, 1980-2012.  All rights reserved.  */
/* Parts Copyright (c) IBM, 1980-2009.                             */
/*                                                                 */
/* Permission to use, copy, modify, and distribute this software   */
/* for any non-commercial purpose without fee is hereby granted,   */
/* provided that the above copyright notice and this permission    */
/* notice appear in all copies, and that notice and the date of    */
/* any modifications be added to the software.                     */
/*                                                                 */
/* This software is provided "as is".  No warranties, whether      */
/* express, implied, or statutory, including, but not limited to,  */
/* implied warranties of merchantability and fitness for a         */
/* particular purpose apply to this software.  The author shall    */
/* not, in any circumstances, be liable for special, incidental,   */
/* or consequential damages, for any reason whatsoever.            */
/*                                                                 */
/* --------------------------------------------------------------- */
/* Argument words:                                                 */
/*                                                                 */
/*   Arg1 is file to display (required)                            */
/*   Arg2 is file to write hex output to [optional]                */
/*   Arg3 is length (bytes) of file to display [optional]          */
/*                                                                 */
/* Note no blanks are alled in file specifications.  This is an    */
/* old program ...                                                 */
/* --------------------------------------------------------------- */
/* 1980?      Initial version                                      */
/* 2004.04.25 Updated for BRexx                                    */
/* 2007.08.20 Add length option for file header display            */
/* 2012.05.27 Cosmetics                                            */

parse arg file outfile partial .

if \datatype(partial, 'w') & partial\='' then do
  say 'Third (length) argument must be a whole number, not:' partial
  exit 1
  end

if file='' then do
  say 'Please enter file to display in hexadecimal (none to quit):'
  parse pull file
  if file='' then exit
  end

file=filequalify(file)
t=filetime(file)
if t=-1 then do
  say ''''file''' was not found or is empty'
  exit 2; end
if outfile\='' then do
  say '[writing to' outfile']'
  call fileerase outfile
  end

/* translate table for unprintables */
outtable=xrange('00'x, 'ff'x)
/*
outtable=copies(' ', 32)xrange('20'x, 'ff'x)
  */
outtable=overlay('fa'x, outtable,  1)        /* 00 - visible 00  */
outtable=overlay(' '  , outtable,  8)        /* 07 -             */
outtable=overlay(' '  , outtable,  9)        /* 08 -             */
outtable=overlay(' '  , outtable, 10)        /* 09 - tab         */
outtable=overlay('d9'x, outtable, 11)        /* 0A - pretty LF   */
outtable=overlay('1b'x, outtable, 14)        /* 0D - pretty CR   */
outtable=overlay('?'  , outtable, 27)        /* 1A - EOF         */

size=chars(file)
if partial\='' then size=min(size, partial)

do start=1 by 16 while size>0
  if size>16 then len=16
             else len=size
  size=size-len
  data=charin(file, start, len)
  xdata=c2x(data)
  tdata=translate(data, outtable)
  rec=d2x(start-1,8)' ',
      substr(xdata, 1,8) substr(xdata, 9,8),
      substr(xdata,17,8) substr(xdata,25,8),
      '',
      substr(tdata, 1,8) substr(tdata, 9,8)
  if outfile='' then say rec
                else call lineout outfile, rec
  end start

call fileclose file
if outfile\='' then call fileclose outfile
exit


/* --------------------------------------------------------------- */
/* Get file date and time in format yyyy-mm-dd hh:mm:ss            */
/* --------------------------------------------------------------- */
/* System-dependent routine; exits if cannot do                    */
/* Returns -1 if unknown                                           */
filetime: procedure
  parse arg file
  parse version rex +7
  select
    when rex='OBJREXX' | rex='REXX-oo' then return sysgetfiledatetime(file, 'w')
    when rex='REXX_BN' then do /* BRexx */
      parse value dir(filequalify(file)) with . size date time .
      if size='' then return -1
      return date time
      end
    otherwise
      say "Cannot determine file date/time using '"rex"' please",
          "update 'filetime' subroutine"
    end
  exit

/* --------------------------------------------------------------- */
/* Erase a file (if it exists)                                     */
/* --------------------------------------------------------------- */
/* System-dependent routine; exits if cannot do                    */
/* Returns 0 if OK or 1 if file not found                          */
fileerase: procedure
  parse arg file
  parse version rex +7
  select
    when rex='OBJREXX' | rex='REXX-oo' then return \(sysfiledelete(file)=0)
    when rex='REXX_BN' then return \delfile(filequalify(file))
    otherwise
      say "Cannot delete file using '"rex"' please",
          "update 'fileerase' subroutine"
    end
  exit

/* --------------------------------------------------------------- */
/* Close a file (if it exists)                                     */
/* --------------------------------------------------------------- */
/* System-dependent routine; exits if cannot do                    */
/* Returns 0 always                                                */
fileclose: procedure
  parse arg file
  parse version rex +7
  select
    when rex='OBJREXX' | rex='REXX-oo' then call lineout file
    when rex='REXX_BN' then call close filequalify(file)
    otherwise
      say "Cannot close file using '"rex"' please",
          "update 'fileclose' subroutine"
      exit
    end
  return 0

/* --------------------------------------------------------------- */
/* Qualify a file name (add full path if none)                     */
/* --------------------------------------------------------------- */
/* Currently does not check the file exists, simply adds current   */
filequalify: procedure
  parse arg file
  if pos('\', file)>0 then return file /* already has path */
  return directory()'\'file