/* Transform (german) output of PSTAT /C in a readable format:    */
/* Usage:   PSTATC [+|-|*]                                        */
/* PSTATC + shows all threads, PSTATC - shows only processes.     */
/* PSTATC * creates or updates a PMREXX object for PSTATC -.      */
/*                                  Frank Ellermann, 1998, 2001   */

   signal on syntax name TRAP    ;  signal on novalue  name TRAP
   signal on halt   name TRAP    ;  signal on failure  name TRAP
   arg ARG                       ;  call UTIL 'SysCls'

   select
      when ARG = '+' | ARG = '-' then nop
      when ARG = '*' then do
         parse source . . ARG    ;  TMP = MAKE()
         call UTIL 'SysSetObjectData'
         call INIT TMP, 'EXENAME=PMREXX.EXE'
         call INIT TMP, 'MINIMIZED=NO'
         call INIT TMP, 'PARAMETERS=/Q' ARG '-'
         exit WAIT( '(re)created object' TMP )
      end
      otherwise
         parse source . . ARG
         ARG =        'usage:' ARG '[+|-|*]'       || x2c( 0D0A )
         ARG = ARG || '    +: show all threads'    || x2c( 0D0A )
         ARG = ARG || '    -: show only processes' || x2c( 0D0A )
         ARG = ARG || '    *: update WPS object'
         exit WAIT( ARG )
   end

   TMP = RxQueue( 'Set', rxqueue( 'Create' ))
   signal on syntax name QERR    ;  signal on novalue  name QERR
   signal on halt   name QERR    ;  signal on failure  name QERR
   do while LOOP( ARG ) ;  nop   ;  end
   exit RxQueue( 'Delete', rxqueue( 'Set', TMP ))

INIT: procedure                  /* modify program object setup:  */
   if SysSetObjectData( arg(1), arg(2)) then return
   exit TRAP( "cannot set" arg(1) arg(2))

LOOP: procedure
   address CMD '@( PSTAT /c | RXQUEUE' rxqueue( 'Get' ) ')'
   if rc <> 0 | queued() = 0
      then return WAIT( 'PSTAT /C output lost, RXQUEUE rc:' rc  )

   /* process queued PSTAT /C output, i.e. skip its header in     */
   /* whatever national language, and rearrange output columns    */
   /* to fit: process NAME last, less spaces.  The header ends    */
   /* with the 2nd blank line (SKIP = 2).                         */

   arg ARG  ;  parse upper source . . NAME
   LINE.. = '/dev/nul'           /* don't create a LINE log file  */
   LINE.0 = 1                    /* message line count for LINE() */
   LINE.1 = NAME                 /* message header                */

   THREAD = 0 ; PPID = '----'                /* initial values    */
   SKIP   = 2 ; PID  = '----' ; PATH = '*script' NAME 'error*'
   SGR = '--' ; CNT.THREAD = 0               /* ARG = '-' counter */

   do while queued() > 0
      pull LINE
      select
         when LINE = '' then SKIP = SKIP - 1
         when SKIP > 0  then iterate         /* skip header (NLS) */
         when words( LINE ) = 4  then do     /* got a thread line */
            parse var LINE TID PRIO BLK STAT
            CNT.THREAD = CNT.THREAD + 1      /* ARG = '-' counter */
            if ARG = '-' then do             /* BLOCKed is boring */
               if STAT = 'BLOCK'          then iterate
               if STAT.THREAD <> 'BLOCK'  then iterate
               STAT.THREAD = STAT   ;  TID.THREAD = TID
               PRIO.THREAD = PRIO   ;  BLK.THREAD = BLK
               iterate                       /* note only process */
            end                              /* else '+' note all */
            THREAD = THREAD + 1  ;  CNT.THREAD = 0
            PPID.THREAD = PPID   ;  PID.THREAD = PID
            PATH.THREAD = PATH   ;  BLK.THREAD = BLK
            PRIO.THREAD = PRIO   ;  TID.THREAD = TID
            STAT.THREAD = STAT   ;  SGR.THREAD = SGR
         end
         when words( LINE ) = 8 then do      /* new process line: */
            parse var LINE PID PPID SGR PATH TID PRIO BLK STAT
            THREAD = THREAD + 1  ;  CNT.THREAD = 1
            PPID.THREAD = PPID   ;  PID.THREAD = PID
            PATH.THREAD = PATH   ;  BLK.THREAD = BLK
            PRIO.THREAD = PRIO   ;  TID.THREAD = TID
            STAT.THREAD = STAT   ;  SGR.THREAD = SGR
         end
         otherwise
            call LINE 'unexpected line - check script' NAME || ':'
            call LINE LINE
      end
   end

   LINE = 'Process-ID PPID SG #T Prio Block-ID  Status ' NAME
   if LINE.0 = 1  then LINE.1 = LINE   ;  else call LINE LINE

   do N = 1 to THREAD
      if ARG = '-' then TID.N = left( CNT.N, 2 )
      LINE = right( x2d( PID.N ), 5 ) PID.N PPID.N SGR.N
      PATH = PATH.N
      if PATH = SKIP then PATH = '' ; else SKIP = PATH
      LINE = LINE TID.N PRIO.N BLK.N left( STAT.N, 8 )
      if length( LINE PATH ) > 79 then
         PATH = '...' || right( PATH, 75 - length( LINE ))
      call LINE LINE PATH
   end

   if ARG = '-'   then LINE = 'processes' ;  else LINE = 'threads'
   LINE = 'total:' THREAD LINE   /* summary line is always shown  */

   if PROC() <> 3 | LINE.0 > 24 | 1 then do
      call SysCls                /* if VIO clear screen and show  */
      do N = 1 to LINE.0         /* collected output.  SORRY, but */
          say LINE.N             /* a proportional RxMessageBox() */
      end N                      /* font is nonsense, therefore   */
   end                           /* the ELSE code is disabled...  */
   else do                       /* ----------------------------- */
      call LINE LINE ;  LINE = LINE.1        /* N E V E R M O R E */
      do N = 2 to LINE.0                     /* save summary and  */
         LINE = LINE || x2c( 0A ) || LINE.N  /* copy collected    */
      end N                                  /* output to summary */
   end                           /* ----------------------------- */
   return WAIT( LINE )           /* use RxMessageBox() of summary */

QERR:                            /* delete Queue, preserve result */
   signal on syntax name TRAP    ;  signal on novalue  name TRAP
   signal on halt   name TRAP    ;  signal on failure  name TRAP
   TRAP = RxQueue( 'Delete', RxQueue( 'Get' ))  ;  signal TRAP

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

LINE: procedure expose LINE.     /* note next global output LINE. */
   signal off notready           ;  call lineout LINE.. , arg( 1 )
   L = LINE.0 + 1 ;  LINE.0 = L  ;  LINE.L = arg( 1 ) ;  return L

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()

MAKE: procedure                  /* recreate or update WPS object */
   /* 1st arg: optional object title, default name of source      */
   /* 2nd arg: optional start arg.s,  use '[txt]' if interactive  */
   /* 3rd arg: optional start directory, default TMP environment  */
   TMP = value( 'TMP',, 'OS2ENVIRONMENT' )
   if TMP = '' then TMP = directory()
   call UTIL 'SysCreateObject'      ;  call UTIL 'SysGetEA'
   parse upper source . . SRC       ;  POS = lastpos( '\', SRC )
   TXT = substr( SRC, POS + 1 )     ;  DIR = left( SRC, POS )
   OBJ = '<' || TXT || '>'          ;  POS = lastpos( '.', TXT )
   TXT = left( TXT, POS - 1 )       ;  NEW = 0

   ICO = stream( DIR || TXT || '.ICO', 'c', 'query exists' )
   if ICO = '' & SysGetEA( SRC, '.ICON', 'POS' ) = 0 then do
      call UTIL 'SysTempFileName'   ;  call UTIL 'SysFileDelete'
      signal on notready name TRAP  ;  SET = substr( POS, 5 )
      NEW = ( length( SET ) = c2d( reverse( substr( POS, 3, 2 ))))
      NEW = NEW & abbrev( POS, x2c( 'F9FF' ))
      if NEW then do             /* SysTempFileName error ignored */
         ICO = SysTempFileName( TMP || '\TMP?????.ICO' )
         call charout ICO, SET      ;  call charout ICO
      end
   end

   if arg( 3, 'O' ) then DIR = TMP  ;  else DIR = arg( 3 )
   if arg( 1, 'E' ) then TXT = arg( 1 )

   SET = 'EXENAME=*;PARAMETERS=/C' strip( SRC arg( 2 ))
   SET = SET || ';MINIMIZED=YES;PROGTYPE=PM'
   if ICO <> '' then SET = SET || ';ICONFILE=' || ICO
   SET = SET || ';STARTUPDIR=' || DIR || ';OBJECTID=' || OBJ || ';'

   POS = '<WP_DESKTOP>'
   POS = SysCreateObject( 'WPProgram', TXT, POS, SET, 'Update' )
   if NEW then call SysFileDelete ICO
   if POS then return OBJ        /* ready to create shadow etc.   */
          else exit TRAP( 'fatal - cannot update' OBJ )

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 1 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 0 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  */