/* OS/2 REXX - emulate 3 missing RexxUtil procedures for RexxMail */
/* not included in Warp 3 connect FixPak 40 RexxUtil.dll (I'm not */
/* tempted to use Object Rexx).                                   */
/* Installation:  Copy this script into any directory of the PATH */
/* or into RexxMail's directory.  Create two copies with the file */
/* names SysGetFileDateTime.cmd and SysSetFileDateTime.cmd - or   */
/* call SysUtilVersion.cmd on the command line without arguments, */
/* it then copies itself using file names Sys?etFileDateTime.cmd. */

/* The emulated SysUtilVersion returns a faked 2.01 if some other */
/* required RexxUtil procedures are available (1.99 otherwise).   */
/* The emulated SysGetFileDateTime uses Quercus DosFileInfo or a  */
/* faked REXX stream() command "query timestamp".                 */
/* The emulated SysSetFileDateTime uses Quercus DosFDate or tries */
/* '@copy "' || file || '" /B ,,+ > /dev/nul"' where possible.    */
/* More procedures could be emulated using Quercus REXX/Personal. */

/* Bug fix:  REXX/Personal has no 'query timestamp', use the old  */
/* 'query datetime' to get the last write access timestamp.       */

/* Problem:  The syntax shown in REXX Tips & Tricks 3.x allows to */
/* set only the time with SysSetFileDateTime( file, time ), or to */
/* set only the date with SysSetFileDateTime( file, date ), or to */
/* set date and time with SysSetFileDateTime( file, date, time ). */
/* SysSetFileDateTime( file, /**/, time ) is _apparently_ illegal */
/* - and the emulation intentionally fails in this case.  Please  */
/* tell me what the real SysSetFileDateTime( file ,, time ) does. */

   signal on  novalue  name TRAP ;  signal on  syntax name TRAP
   signal on  failure  name TRAP ;  signal on  halt   name TRAP

   parse source OS AS PATH       ;  parse version . NN .

   NAME = translate( translate( PATH, '/', '\' ))
   NAME = substr( NAME, 1 + lastpos( '/', NAME ))
   select
      when 'OS/2'    <> OS then  exit USAGE( 'unsupported OS' OS )
      when '4.00'    <> NN then  exit USAGE( 'unexpected REXX' NN )
      when 'COMMAND' =  AS & arg() <= 1 & arg( 1 ) = '' /**/ , /**/
         & NAME = 'SYSUTILVERSION.CMD'       then do
         NN = '> /dev/nul'       ;  signal on error name TRAP
         AS = left( PATH, length( PATH ) - length( NAME ))
         NAME = AS || 'SysGetFileDateTime.cmd'
         address CMD '@copy "' || PATH || '" "' || NAME || '"' NN
         NAME = AS || 'SysSetFileDateTime.cmd'
         address CMD '@copy "' || PATH || '" "' || NAME || '"' NN
         exit rc
      end
      when 'COMMAND' =  AS then  exit USAGE( NAME 'is no' AS )
      when NAME = 'SYSUTILVERSION.CMD'       then nop
      when NAME = 'SYSGETFILEDATETIME.CMD'   then nop
      when NAME = 'SYSSETFILEDATETIME.CMD'   then nop
      otherwise                  exit USAGE( NAME 'not emulated' )
   end
   /* ----------------------------------------------------------- */
   if NAME = 'SYSUTILVERSION.CMD' then do
      if arg() > 0 then do
         if AS = 'FUNCTION'   then return /* throw REXX error 44  */
         return abs( /* throw REXX error 40 */ )
      end
      if RxFuncQuery( 'SysSetProcessCodePage'   )  then  return 1.99
      if RxFuncQuery( 'SysSetPriority'          )  then  return 1.99
      if RxFuncQuery( 'SysCreateMutexSem'       )  then  return 1.99
      return PREXX()
   end
   /* ----------------------------------------------------------- */
   if NAME = 'SYSGETFILEDATETIME.CMD' then do
      NN = translate( arg( 2 ))
      select
         when NN = ''            then  NN = ''
         when abbrev( NN, 'W' )  then  NN = ''
         when abbrev( NN, 'C' )  then  NN = 'C'
         when abbrev( NN, 'A' )  then  NN = 'A'
         otherwise                     NN = '?'
      end
      if arg( 1 ) = '' | NN = '?' | arg() > 2 then do
         if AS = 'FUNCTION'   then return /* throw REXX error 44  */
         return abs( /* throw REXX error 40 */ )
      end
      if NN <> '' & RxFuncQuery( 'DosFileInfo' ) = 0 then do
         call DosFileInfo arg( 1 ), NN
         parse var result MM '/' DD '/' YY NN
         if YY <   80   then YY = YY + 2000  /* Y2K QREXXLIB.dll  */
         if YY < 1000   then YY = YY + 1900  /* Y2K  REXXLIB.dll  */
         if MM =    0   then return -1       /* FAT query invalid */
         return YY || '-' || MM || '-' || DD NN
      end
      NN = PREXX( arg( 1 ))   ;  if NN <> '' then return NN
      return -1                              /* -1 file not found */
   end
   /* ----------------------------------------------------------- */
   if NAME = 'SYSSETFILEDATETIME.CMD' then do
      if arg( 1 ) = '' | arg() > 3 then do
         if AS = 'FUNCTION'   then return /* throw REXX error 44  */
         return abs( /* throw REXX error 40 */ )
      end
      if RxFuncQuery( 'DosFDate' ) then do
         if arg() > 1 then return -1
         address CMD '@copy "' || arg( 1 ) || '" /B ,,+ > /dev/nul'
         return ( rc = 0 ) - 1      /* 0: okay, -1: error         */
      end

      if arg() > 1   then NN = strip( arg( 2 ))
                     else return DosFdate( arg( 1 )         ) - 1
      parse var NN YY '-' MM '-' DD    ;  DD = YY || MM || DD
      if MM <> ''    then NN = strip( arg( 3 ))
      parse var NN HH ':' NN ':' SS    ;  NN = HH || NN || SS
      if MM = ''     then return DosFdate( arg( 1 ),   , NN ) - 1
      if NN = ''     then return DosFdate( arg( 1 ), DD     ) - 1
                     else return DosFdate( arg( 1 ), DD, NN ) - 1
   end
/* -------------------------------------------------------------- */

PREXX:   procedure expose PATH      /* load Quercus procedures or */
   if arg( 1, 'e' ) then do         /* query timestamp for a file */
      signal on syntax name PREXX.3
      return stream( arg( 1 ), 'c', 'query timestamp' )
   end
   USE = 'DosFileInfo'              ;  DLL = 'REXXLIB'
   if RxFuncQuery( USE ) then call RxFuncAdd USE, DLL, 'LIB_' || USE
   signal on syntax name PREXX.1    ;  interpret 'call' USE
PREXX.1:                            /* no error (no rc) is fatal, */
   if rc =  43 then do              /* rc = 40 or rc = 43 is okay */
      call RxFuncDrop USE           ;  DLL = 'QREXXLIB'
      call RxFuncAdd  USE, DLL, 'LIB_' || USE
      signal on syntax name PREXX.2 ;  interpret 'call' USE
   end
PREXX.2:                            /* rc = 40 or rc = 43 is okay */
   if rc <> 40 & rc <> 43 then exit TRAP( USE || '() rc =' rc '?' )
   if rc =  40 then do
      USE = 'DosFDate'
      if RxFuncQuery( USE ) then do
         if RxFuncAdd( USE, DLL, 'LIB_' || USE ) then rc = 43
      end
   end
   if rc =  43 then call RxFuncDrop USE
   return 2.01

PREXX.3:                         /* emulate new 'query timestamp' */
   signal on syntax name TRAP    /* (necessary for REXX/Personal) */
   NN = stream( arg( 1 ), 'c', 'query datetime' )
   if NN = '' then return NN           /* Quercus Y2K workaround, */
   parse var NN MM '-' DD '-' YY NN    /* should work until 2079  */
   if YY < 80 then   YY = YY + 2000 ;  else  YY = YY + 1900
   return YY || '-' || MM || '-' || DD NN

/* -------------------------------------------------------------- */

USAGE:   procedure
   TXT = '' ;  EOL = x2c( 0D0A )
   do N = 1 to sourceline()
      NXT = sourceline( N )
      if NXT <> '' then do
         parse var NXT '/* ' NXT ' */' ;  if NXT = '' then leave N
      end
      TXT = TXT || EOL || NXT
   end N
   return WAIT( TXT || EOL || arg( 1 ))

/* see <URL:http://purl.net/xyzzy/rexxtrap.htm>, (c) F. Ellermann */

WAIT: procedure                  /* get OKay (or CANCEL) answer:  */
   KEY = PROC()                  ;  OUT = 'STDERR'

   select
      when KEY = 1 then do       /* 1 (real) obsolete: here DOS   */
         parse version KEY . .   /* REXX/Personal has no STDERR:  */
         if KEY <> 'REXXSAA' then OUT = '\dev\con'
      end
      when KEY = 3 then do       /* 3 (PM) RxMessageBox() output  */
         parse source KEY  ;  KEY = centre( KEY, 100 )   /* HACK  */
         KEY = RxMessageBox( arg( 1 ), KEY, 'OKCANCEL', 'ASTERISK' )
         return KEY = 1 | KEY = 6 | KEY = 8
      end                        /* 0 (fullscreen) and 2 (window) */
      when KEY < 4 then call UTIL 'SysGetKey'
      otherwise nop              /* 4 (detached) tested in AKEY() */
   end
   call charout OUT, arg( 1 ) || x2c( 7 )

   do until c2d( KEY ) <> 0 & c2d( KEY ) <> 224
      KEY = AKEY()
   end
   call lineout OUT, ''          /* hardwiring F3 '=', Alt-F4 'k' */
   return KEY <> x2c( 1B ) & KEY <> '=' & KEY <> 'k'

AKEY: procedure                  /* keyboard char. input function */
   KEY = PROC()
   if KEY == 4          then return x2c( 1B )      /* 4: detached */
   if KEY <> 1          then return SysGetKey( 'NoEcho' )
   parse version KEY . .                           /* 1: DOS REXX */
   if KEY == 'REXXSAA'  then return  RxGetKey( 'NoEcho' )
                        else return right( INKEY(), 1 )

PROC: procedure                  /* avoid "unknown function" TRAP */
   parse source OS .             /* for REXXSAA portability abuse */
   if OS <> 'OS/2' then return 1 /* the now obsolete 1: real mode */

   OS = 'ProcessType'            /* assume Sys... = RxProcessType */
   if RxFuncQuery( 'Sys' || OS ) = 0 then return SysProcessType()
   if RxFuncAdd(   'Sys' || OS, 'RxUtils', 'Rx' || OS ) = 0 then do
      signal on syntax name PROC.TRAP  ;  return SysProcessType()
   end                           /* tries RxUtils only once, else */
PROC.TRAP:                       /* force RexxUtil SysProcessType */
   call  RxFuncDrop 'SysProcessType'   ;  signal on syntax name TRAP
   call        UTIL 'SysProcessType'   ;  return SysProcessType()

UTIL: procedure                  /* load necessary RexxUtil entry */
   if RxFuncQuery(  arg( 1 )) then
      if RxFuncAdd( arg( 1 ), 'RexxUtil', arg( 1 )) then
         exit TRAP( "can't add RexxUtil"  arg( 1 ))
   return 0

TRAP:                            /* select REXX exception handler */
   call trace 'O' ;  trace N           /* don't trace interactive */
   parse source TRAP                   /* source on separate line */
   TRAP = x2c( 0D ) || right( '+++', 10 ) TRAP || x2c( 0D0A )
   TRAP = TRAP || right( '+++', 10 )   /* = standard trace prefix */
   TRAP = TRAP strip( condition( 'c' ) 'trap:' condition( 'd' ))
   select
      when wordpos( condition( 'c' ), 'ERROR FAILURE' ) > 0 then do
         if condition( 'd' ) > ''      /* need an additional line */
            then TRAP = TRAP || x2c( 0D0A ) || right( '+++', 10 )
         TRAP = TRAP '(RC' rc || ')'   /* any system error codes  */
         if condition( 'c' ) = 'FAILURE' then rc = -3
      end
      when wordpos( condition( 'c' ), 'HALT SYNTAX'   ) > 0 then do
         if condition( 'c' ) = 'HALT' then rc = 4
         if condition( 'd' ) > '' & condition( 'd' ) <> rc then do
            if condition( 'd' ) <> errortext( rc ) then do
               TRAP = TRAP || x2c( 0D0A ) || right( '+++', 10 )
               TRAP = TRAP errortext( rc )
            end                        /* future condition( 'd' ) */
         end                           /* may use errortext( rc ) */
         else  TRAP = TRAP errortext( rc )
         rc = -rc                      /* rc < 0: REXX error code */
      end
      when condition( 'c' ) = 'NOVALUE'  then rc = -2 /* dubious  */
      when condition( 'c' ) = 'NOTREADY' then rc = -1 /* dubious  */
      otherwise                        /* force non-zero whole rc */
         if datatype( value( 'RC' ), 'W' ) = 0 then rc = 1
         if rc = 0                             then rc = 1
         if condition() = '' then TRAP = TRAP arg( 1 )
   end                                 /* direct: TRAP( message ) */

   TRAP = TRAP || x2c( 0D0A ) || format( sigl, 6 )
   signal on syntax name TRAP.SIGL     /* throw syntax error 3... */
   if 0 < sigl & sigl <= sourceline()  /* if no handle for source */
      then TRAP = TRAP '*-*' strip( sourceline( sigl ))
      else TRAP = TRAP '+++ (source line unavailable)'
TRAP.SIGL:                             /* ...catch syntax error 3 */
   if abbrev( right( TRAP, 2 + 6 ), x2c( 0D0A )) then do
      TRAP = TRAP '+++ (source line unreadable)'   ;  rc = -rc
   end
   select
      when 0 then do                   /* in pipes STDERR: output */
         parse version TRAP.REXX . .   /* REXX/Personal: \dev\con */
         signal on syntax name TRAP.FAIL
         if TRAP.REXX = 'REXXSAA'      /* fails if no more handle */
            then call lineout 'STDERR'  , TRAP
            else call lineout '\dev\con', TRAP
      end
      when 1 then do                   /* OS/2 PM: RxMessageBox() */
         signal on syntax name TRAP.FAIL
         call RxMessageBox ,           /* fails if not in PMREXX  */
            translate( TRAP, ' ', x2c( 0D )), , 'CANCEL', 'WARNING'
      end                              /* replace any CR by blank */
      otherwise   say TRAP ; trace ?L  /* interactive Label trace */
   end

   if condition() = 'SIGNAL' then signal TRAP.EXIT
TRAP.CALL:  return rc                  /* continue after CALL ON  */
TRAP.FAIL:  say TRAP ;  rc = 0 - rc    /* force TRAP error output */
TRAP.EXIT:  exit   rc                  /* exit for any SIGNAL ON  */