/* Semi-portable REXX procedures (OS/2, Quercus, PC DOS, ooREXX) */ /* manual : */ /* source : */ /* optional: (KEDIT) */ /* optional: (KEDIT) */ /* "TRAPs and pitfalls" section moved to the manual. Procedures: */ /* TEST OS/2 (CMD, PM, DETACH) + DOS (REXXSAA, REXX/Personal) */ /* SHOW and LINE are too clumsy, don't use it in further scripts: */ /* LINE.0 number of LINE.s for SHOW() or LINE(), init. by user */ /* LINE.1 message header, for LINE.0 < 2 SHOW() simply returns */ /* LINE.. LINE() log, e.g. '', '\dev\nul', 'STDERR', 'logfile' */ /* LINE add LINE.s for later exit SHOW(), log line in LINE.. */ /* SHOW: RxMessageBox() of LINE.s or SAY if too many or no PM */ /* BOOT: deprecated, now just returns RexxUtil SysBootDrive() */ /* TREE: deprecated SysFileTree() emulation for DOS REXXSAA or */ /* DOS Rexx/personal. In 2008 the REXXSAA code path was */ /* found to fail in an NT DOS box, likely a problem with */ /* PC DOS 7 RXFINFO.RX. */ /* PROC, MAKE, RENO, and XEAT require OS/2, not tested by TEST(): */ /* PROC: OS/2 SysProcessType() / DOS: 1 / WindowsNT ooREXX: 0 */ /* MAKE: (re)create WPS object for calling script w/ options */ /* RENO: rename WPS Object id. */ /* XEAT: SysGetEA / SysPutEA a file's .TYPE into / from STEM, */ /* see also */ /* KWIK sort STEM.n from n = 1 up to STEM.0 not tested by TEST(): */ /* KWIK: see also */ /* UTIL, WARN, OKAY, WAIT, and AKEY are fine for portability, but */ /* OKAY, WAIT, and AKEY need PROC for special OS/2 cases */ /* UTIL: (re)load required RexxUtil function, else TRAP() */ /* WARN: RxMessageBox( Ok ) / lineout 'STDERR' */ /* OKAY: RxMessageBox( YesNoCancel ) / AKEY() Y:1 N:0 */ /* WAIT: RxMessageBox( OkCancel ) / AKEY() any:1 ESC:0 */ /* AKEY: SysGetKey( NoEcho ) / RxGetKey( NoEcho ) / INKEY() */ /* XDIR, XDEL, XENV, and XRMD are nice for portable REXX scripts: */ /* XDIR: directory() or if DOS REXXSAA a simulated directory() */ /* XENV: value( arg(1), [arg(2)], [DOS|OS2]ENVIRONMENT ) */ /* XRMD: SysRmDir() / RxRmDir() / DosRmDir() */ /* XDEL: SysFileDelete() / RxDelete() / DosDel() file deletion */ /* Test case 13 fails for DOS REXXSAA because RxDelete() */ /* deletes locked files. Nobody uses DOS REXXSAA today. */ /* TRAP: exception handler or as emergency exit TRAP( msg ) */ /* For ooREXX this is mostly pointless, for older REXX */ /* interpreters it used to be helpful */ /* Features of TRAP handler: can be configured by SELECT WHEN 1 */ /* to use "STDERR:" for output (necessary in REXX filters) or */ /* to use RxMessageBox() if available. OTHERWISE error output is */ /* shown by SAY with interactive tracing. */ signal on novalue name TRAP ; signal on syntax name TRAP signal on failure name TRAP ; signal on halt name TRAP if address() = 'PMREXX' then address CMD /* handling FAILUREs */ if address() = 'DOS' then options 'NEWCOM' if address() = 'CMD' then '@echo OFF' /* relevant for OS/2 */ parse version TMP OLD . /* log file including any LINE() */ if TMP == 'REXXSAA' | 6 <= OLD then LINE.. = 'STDERR' else LINE.. = '\dev\con' LINE.0 = 1 /* message line count for LINE() */ parse source LINE.1 /* message header in exit SHOW() */ arg CASE /* ---- begin of test suite ---- */ TMP = XENV( 'TMP' ) || '\$$test$$.' /* Hack for ooREXX on NT: If TMP is a short name for what is */ /* actually a long directory name test 16 fails. In fact this */ /* is an issue with SysFileTree(), but no problem in TREE(). */ if sign( pos( '~', TMP )) then do OLD = XDIR() ; TMP = left( TMP, 3 ) || 'TMP' if TMP <> XDIR( TMP ) then do call XDIR OLD /* give up, found no old ?:\TMP */ exit TRAP( 'short TMP directory name not yet supported' ) end /* else using ?:\TMP for test 16 */ call XDIR OLD ; TMP = TMP || '\$$test$$.' end TMP = translate( TMP ) /* use uppercase for DOS NT OS/2 */ select when CASE = 0 then do if OKAY( 'test 1 shell return ?' ) then call TEST 1 if OKAY( 'test 2 divide error ?' ) then call TEST 2 if OKAY( 'test 3 NOVALUE trap ?' ) then call TEST 3 if OKAY( 'test 4 syntax error ?' ) then call TEST 4 if OKAY( 'test 5 ESC (or F3) ?' ) then call TEST 5 if OKAY( 'test 6 SIGABRT halt ?' ) then call TEST 6 if OKAY( 'test 7 FAILURE trap ?' ) then call TEST 7 if OKAY( 'test 8 ERROR signal ?' ) then call TEST 8 if OKAY( 'test 9 ERROR return ?' ) then call TEST 9 if OKAY( 'test 10 ERROR ignore ?' ) then call TEST 10 if OKAY( 'test 11 program TRAP ?' ) then call TEST 11 if OKAY( 'test 12 signal TRAP ?' ) then call TEST 12 if OKAY( 'test 13 various XDEL ?' ) then call TEST 13 if OKAY( 'test 14 various XDIR ?' ) then call TEST 14 if OKAY( 'test 15 expose TREE ?' ) then call TEST 15 if OKAY( 'test 16 various TREE ?' ) then call TEST 16 if OKAY( 'test 17 stderr WARN ?' ) then call TEST 17 if OKAY( 'test 18 various XENV ?' ) then call TEST 18 if OKAY( 'test 19 XRMD subdir. ?' ) then call TEST 19 if OKAY( 'test 20 [dummy case] ?' ) then call TEST 20 if OKAY( 'test 21 [dummy case] ?' ) then call TEST 21 if OKAY( 'test 22 [dummy case] ?' ) then call TEST 22 if OKAY( 'test 23 [dummy case] ?' ) then call TEST 23 if OKAY( 'test 24 file handles ?' ) then call TEST 24 end /******* -0 */ when CASE = 1 then exit -1 when CASE = 2 then interpret '1 // 0' when CASE = 3 then interpret '1 // NUL' when CASE = 4 then interpret 'call NUL' when CASE = 5 then exit WAIT( 'press ESCape' ) when CASE = 6 then call WAIT 'press ^BREAK' /* test RC =-4 */ when CASE = 7 then address NUL 'NUL' /* get failure */ when CASE = 8 then do /* force DOS or OS/2 error 1: */ signal on error name TRAP ; 'ECHO | FIND "nothing"' exit 0 /* test RC = 1 */ end /******* +8 */ when CASE = 9 then do /* force DOS or OS/2 error 1: */ call on error name TRAP ; 'ECHO | FIND "nothing"' return rc + 1 /* test RC = 2 */ end /******* +9 */ when CASE = 10 then do /* force DOS or OS/2 error 1: */ call off error ; 'ECHO | FIND "nothing"' return rc + 2 /* test RC = 3 */ end /******* 10 */ when CASE = 11 then exit TRAP( 'test' ) + 3 /* test RC = 4 */ when CASE = 12 then interpret 'rc = 5 ; signal TRAP' when CASE = 13 then do /* test various file XDELetions: */ call XDEL TMP || 'tmp' ; rc = 0 rc = XDEL( TMP || 'tmp' ) + rc /* 1: XDEL non-existing */ call lineout TMP || 'tmp',, 1 /* 2: XDEL locked file */ rc = XDEL( TMP || 'tmp' ) + rc call lineout TMP || 'tmp' OLD = ( stream( TMP || 'tmp', 'c', 'query exists' ) > '' ) rc = OLD + rc /* 3: empty TMP exists */ exit XDEL( TMP || 'tmp' ) + rc /* 4: XDEL closed file */ end /******* 13 **** CAVEAT: TEST( 13 ) handled specially */ when CASE = 14 then do /* test some XDIRectory changes: */ CASE = XDIR() if XDIR( '@:\' ) <> '' then exit 1 /* bad disk */ if XDIR( TMP ) <> '' then exit 2 /* bad dir. */ if XDIR( TMP || '\..' ) == '' then exit 3 /* TMP dir. */ if XDIR( CASE ) <> CASE then exit 4 /* old dir. */ if XDIR( . ) <> CASE then exit 5 ; else exit 6 end /******* 14 */ when CASE = 15 then do /* test TREE() expose behaviour */ FOUND.0 = 10 ; rc = TREE( 1, 'FOUND', 3, 4 ) if FOUND.0 <> 0 then exit rc + FOUND.0 /* test RC = 1 */ drop FOUND. ; rc = TREE( 1, 'FOUND', 3, 4 ) if symbol( 'FOUND.0' ) = 'VAR' then exit rc + FOUND.0 else exit rc + 20 end /******* 15 */ when CASE = 16 then do /* test SysFileTree() simulation */ rc = TREE( left( TMP, 3 ) || '*.*', 'FOUND', 'DOS' ) do CASE = 1 to FOUND.0 /* find TMP in subdirectory TREE */ rc = rc + abbrev( TMP, translate( FOUND.CASE )) end CASE /* once RC = 1 */ if rc <> 1 then exit 10 + rc /* failure: 1? */ call TREE TMP, 'FOUND', 'DS' /* not found 0 */ rc = rc + FOUND.0 /* zero RC = 1 */ if rc <> 1 then exit 20 + rc /* failure: 2? */ CASE = translate( subword( LINE.1, 3 )) call TREE CASE, 'FOUND' /* pos. RC = 2 */ rc = rc + sign( pos( CASE, translate( FOUND.1 ))) if rc <> 2 then exit 30 + rc /* failure: 3? */ CASE = substr( CASE, lastpos( '.', CASE )) CASE = left( subword( LINE.1, 3 ), 3 ) || '*' || CASE call TREE CASE, 'FOUND', 'FOS' do CASE = 1 to FOUND.0 /* find the running REXX script: */ FOUND.CASE = translate( FOUND.CASE ) if abbrev( FOUND.CASE, translate( subword( LINE.1, 3 ))) then rc = rc + 1 /* once RC = 3 */ end CASE if rc <> 3 then exit 40 + rc /* failure: 4? */ exit rc /* test RC = 3 */ end /******* 16 */ when CASE = 17 then exit WARN( 'test line' ) /* test RC = 0 */ when CASE = 18 then do /* test some XENV() combinations */ OLD = XENV( 'rexxtrap test' ) ; rc = 0 rc = rc + ( OLD == '' ) /*********************/ OLD = XENV( 'rexxtrap test', TMP ) /* DOS REXXSAA value */ rc = rc + ( OLD == '' ) /* function supports */ OLD = XENV( 'rexxtrap test', 123 ) /* at most one space */ rc = rc + ( OLD == TMP ) /* in DOSENVIRONMENT */ call XENV 'rexxtrap test' /* variable names. */ rc = rc + ( result = 123 ) /* Setting variables */ OLD = XENV( 'rexxtrap test', '' ) /* sometimes crashes */ rc = rc + ( OLD == 123 ) /* the PC DOS shell. */ OLD = XENV( 'rexxtrap test' ) /*********************/ rc = rc + ( OLD == '' ) ; parse version . OLD . if OLD < 6 then rc = rc + 1 ; else do OLD = XENV( 'rexxtrap test', .nil ) rc += ( OLD == '' ) /* .nil and += need Object REXX */ end exit rc /* test RC = 7 */ end /******* 18 */ when CASE = 19 then do /* XRMD() of CWD should not work */ rc = XRMD( TMP || 'RMD' ) ; OLD = rc if words( TMP ) = 1 then 'md' TMP || 'RMD' else 'md "' || TMP || 'RMD"' rc = OLD ; OLD = XDIR() if XDIR( TMP || 'RMD' ) = TMP || 'RMD' /* use subdir. */ then rc = rc + XRMD( TMP || 'RMD' ) /* should fail */ call XDIR OLD ; call XRMD TMP || 'RMD' if XDIR( TMP || 'RMD' ) = '' & rc = 2 then rc = 3 call XDIR OLD ; exit rc /* test RC = 3 */ end /******* 19 */ when CASE = 20 then exit 0 /* test case 20 not implemented */ when CASE = 21 then exit 0 /* test case 21 not implemented */ when CASE = 22 then exit 0 /* test case 22 not implemented */ when CASE = 23 then exit 0 /* test case 23 not implemented */ when CASE = 24 then do CASE = 0 to 999 signal on notready name TRAP rc = lineout( TMP || right( CASE, 3, 0 ) ,, 1 ) if rc = 0 then iterate CASE /* file opened */ exit rc /* bad: 1, okay: -1, REXXSAA: -3 */ end CASE /* 24 **** CAVEAT: TEST( 24 ) handled specially */ when CASE = .. then do CASE = 1 to 24 call TEST CASE end CASE /* .. */ when datatype( CASE, 'w' ) & CASE < 0 then do signal off notready /* DOS \dev\nul is never ready ? */ LINE.. = '\dev\nul' ; call TEST 0 - CASE end /******* -n */ when CASE = '' | wordpos( CASE, '-H -? /H /? ?' ) > 0 then do signal off notready /* DOS \dev\nul is never ready ? */ LINE.. = '\dev\nul' ; parse source . . CASE call LINE 'usage:' CASE '-0|-1|..|-20|.' call LINE 'e.g. :' CASE '.. 2>&1 > NUL | MORE' call LINE 'e.g. : PMREXX' CASE '-0' call LINE 'e.g. : DETACH' CASE '.. 2>x2.log 1>x1.log' call LINE ' -0 starts interactive test' call LINE ' -n tests single case 1..20' call LINE ' .. executes all test cases' call LINE ' . tests CMD + DETACH + PM' end /******* -h */ when CASE = . then do call on failure name TRAP ; signal off notready parse source . . CASE ; call UTIL 'SysSleep' 'DEL' TMP || 'x?x 2>\dev\nul' /* ----------------- */ call LINE 'CMD /c' CASE '.. test' 'CMD /c' CASE '.. >' TMP || 'x0x' if lines( TMP || 'x0x' ) = 0 then call LINE 'FAIL CMD /c' do while lines( TMP || 'x0x' ) > 0 /* get CMD /c STDOUT */ call LINE linein( TMP || 'x0x' ) end /* ----------------- */ call LINE 'DETACH' CASE '.. test' 'DETACH' CASE '.. >' TMP || 'x1x 2>' TMP || 'x2x' do 20 if stream( TMP || 'x2x', 'c', 'query exists' ) > '' then if lineout( TMP || 'x2x', '' ) = 0 then leave call SysSleep 1 /* wait for DETACHed */ end if lines( TMP || 'x1x' ) = 0 then call LINE 'FAIL DETACH' do while lines( TMP || 'x1x' ) > 0 /* get DETACH STDOUT */ call LINE linein( TMP || 'x1x' ) end /* ----------------- */ call LINE 'START /pm CMD /c' CASE '.. test' 'START /pm CMD /c' CASE '.. >' TMP || 'x3x 2>' TMP || 'x4x' do 120 /* 2 min for PM test */ if stream( TMP || 'x3x', 'c', 'query exists' ) > '' then if lineout( TMP || 'x3x', '' ) = 0 then leave call SysSleep 1 /* wait for START PM */ end if lines( TMP || 'x4x' ) = 0 then call LINE 'FAIL PM CMD' do while lines( TMP || 'x4x' ) > 0 /* get PM CMD STDERR */ CASE = linein( TMP || 'x4x' ) if abbrev( CASE, 'FAIL' ) then call LINE CASE if abbrev( CASE, 'PASS' ) then call LINE CASE if abbrev( CASE, 'SKIP' ) then call LINE CASE end /* ----------------- */ do CASE = 1 to LINE.0 until abbrev( LINE.CASE, 'FAIL' ) end CASE /* scan for FAILures */ exit SHOW() = 0 | CASE <= LINE.0 /* 1 if any FAILures */ end /******* . */ otherwise exit 99 + TRAP( 'unexpected argument:' CASE ) end exit SHOW() TEST: procedure expose LINE. TMP /* shell CALL (single test case) */ /* test case 1 2 3 4 5 6 7 8 9 10 11 12 */ GOOD = '-1 -42 -2 -43 0 -4 -3 1 2 3 4 5' /* test case 13 14 15 16 17 18 19 20 21 22 23 24 */ GOOD = GOOD ' 3 6 1 3 0 7 3 0 0 0 0 -1' parse source . . TEST /* simulate CALL VALUE: */ interpret 'call "' || TEST || '"' arg( 1 ) rc = x2d( d2x( result, 2 ), 2 ) /* DOS rc > 127: 0 - rc */ if rc = word( GOOD, arg( 1 )) then TEST = 'PASS test case' arg( 1 ) else TEST = 'FAIL test case' arg( 1 ) '(' || rc || ')' if arg( 1 ) = 6 & rc = 0 & PROC() > 2 then TEST = 'SKIP test case' arg( 1 ) '(PM or detached)' if arg( 1 ) = 13 & rc = 2 & address() == 'DOS' then TEST = 'PASS test case' arg( 1 ) '(REXX/Personal)' if arg( 1 ) = 24 & rc = -3 & address() <> 'DOS' then TEST = 'PASS test case' arg( 1 ) '(REXXSAA)' if arg( 1 ) = 24 then do GOOD = 0 to 999 call stream TMP || right( GOOD, 3, 0 ), 'c', 'query exists' if result = '' then leave GOOD /* XDEL dummy test file */ call stream TMP || right( GOOD, 3, 0 ), 'c', 'close' if XDEL( TMP || right( GOOD, 3, 0 )) then 'DEL' TMP || right( GOOD, 3, 0 ) end GOOD return LINE( TEST ) /* ----- end of test suite ----- */ TREE: /* portable SysFileTree() subset */ if arg( 2, 'o' ) then return abs( /* force TREE syntax error */ ) THIS... = arg( 2 ) /* destroying any global THIS... */ if right( THIS... , 1 ) <> . then THIS... = THIS... || . if arg() < 3 then return TREE.PLUS( arg( 1 )) if arg() = 3 then return TREE.PLUS( arg( 1 ), arg( 3 )) else return TREE.PLUS( arg( 1 ), arg( 3 ), arg( 4 )) TREE.PLUS: procedure expose ( THIS... ) call value THIS... || '0', 0 /* prepare for result STEM.0 = 0 */ if arg() > 2 then return 1 /* attribute masking unsupported */ TOP = translate( arg( 2 )) /* Time option T not implemented */ if verify( TOP, 'FDBOS' ) > 0 then return 1 parse source KEY . . /* ----------------------------- */ if KEY = 'OS/2' | KEY = 'WindowsNT' then do call UTIL 'SysFileTree' if arg() = 1 then return SysFileTree( arg( 1 ), THIS... ) else return SysFileTree( arg( 1 ), THIS... , arg( 2 )) end /* ----------------------------- */ CWD = XDIR() /* transform rel. path into abs. */ SUB.1 = left( arg( 1 ), 0 + lastpos( '\', arg( 1 ))) ANY = substr( arg( 1 ), 1 + lastpos( '\', arg( 1 ))) if ANY = '..' | ANY = '.' then do SUB.1 = SUB.1 || ANY ; ANY = '*.*' end if SUB.1 = '' then do /* SysFileTree( 'D:.', x ) won't */ select /* work if in root dir.: ignored */ when right( ANY, 1 ) = ':' then SUB.1 = ANY || '.' when right( ANY, 2 ) = ':.' then SUB.1 = ANY when right( ANY, 3 ) = ':..' then SUB.1 = ANY when right( CWD, 1 ) = '\' then SUB.1 = CWD otherwise SUB.1 = CWD || '\' end if right( SUB.1, 1 ) <> '\' then do SUB.1 = XDIR( SUB.1 ) ; ANY = '*.*' end /* ANY patched for . and .. */ end /* SUB.1 always XDIR()-tested */ else SUB.1 = XDIR( SUB.1 || '.' ) call XDIR CWD /* reset caller's directory */ if SUB.1 = '' then return 0 /* for bad directory return 0 */ if right( SUB.1 , 1 ) <> '\' then SUB.1 = SUB.1 || '\' parse version KEY . . ; SUB = 1 ; ONE = '' ; NUM = 0 CWD = 1 - sign( pos( 'S', TOP )) /* 0: Subdirectories, 1: here */ FBD = 1 - sign( pos( 'B', TOP )) /* 1: File, 0: Both, -1: Dir. */ if FBD then FBD = sign( pos( 'F', TOP )) - sign( pos( 'D', TOP )) ADD = 1 - sign( pos( 'O', TOP )) /* 0: Only path, 1: more info */ do while ONE > '' | SUB > CWD /* DOS REXX/Personal push & pull */ if ONE = '' then do /* could fail, and REXXSAA stack */ CWD = CWD + 1 /* is limited, build direct TREE */ if KEY = 'REXXSAA' then ONE = RxFInfo( SUB.CWD || '*.*' ) else ONE = DosDir( SUB.CWD || '*.*',, 'HSD', 'D' ) end /* find 1st matching file / dir. */ if sign( pos( 'D', right( ONE, 6 ))) then do ONE = subword( ONE, 1, words( ONE ) - 4 ) if ONE <> '.' & ONE <> '..' then do SUB = SUB + 1 ; SUB.SUB = SUB.CWD || ONE || '\' end /* note additional subdirectory */ end /* get next matching file / dir. */ if KEY = 'REXXSAA' then ONE = RxFInfo() else ONE = DosDir( ) end do CWD = 1 to SUB /* for all noted subdirectories: */ if KEY = 'REXXSAA' /* find 1st matching file / dir. */ then ONE = RxFInfo( SUB.CWD || ANY ) else ONE = DosDir( SUB.CWD || ANY ,, 'HSD' ) do while ONE > '' TOP = subword( ONE, 1 + words( ONE ) - 4 ) /* 4 tokens */ ONE = subword( ONE, 1 , words( ONE ) - 4 ) /* ONE path */ if ONE = '.' | ONE = '..' then ONE = '' if FBD > 0 & pos( 'D', right( TOP, 6 )) <> 0 then ONE = '' if FBD < 0 & pos( 'D', right( TOP, 6 )) == 0 then ONE = '' if ONE > '' then do ONE = SUB.CWD || ONE ; NUM = NUM + 1 if ADD then ONE = TOP ONE /* ADD size date time attr */ call value THIS... || '0', NUM /* next NUM */ call value THIS... || NUM, ONE /* item NUM */ end /* get next matching file / dir. */ if KEY = 'REXXSAA' then ONE = RxFInfo() else ONE = DosDir() end end CWD return 0 XEAT: /* get or put EA TYPE using STEM */ /* 1st arg. = FILE, 3rd arg. = 0 to SysGetEA '.TYPE' into STEM */ /* 2nd arg. = STEM, 3rd arg. = 1 to SysPutEA '.TYPE' from STEM */ /* STEM.0 = last, STEM.n = n-th EAT_ASCII (0 < n <= STEM.0) */ /* STEM.. = '' (one ASCII), 0 or codepage (for MULTI) resp. */ if arg( 2, 'o' ) then return abs( /* missing STEM argument */ ) if arg() <> 3 then return abs( /* missing or extra arg. */ ) THIS... = arg( 2 ) /* destroying any global THIS... */ if right( THIS... , 1 ) <> . then THIS... = THIS... || . if arg( 3 ) then return XEAT.PUTEA( arg( 1 ), '.TYPE' ) else return XEAT.GETEA( arg( 1 ), '.TYPE' ) XEAT.GETEA: procedure expose ( THIS... ) call UTIL 'SysGetEA' ; MULTI = reverse( x2c( 'FFDF' )) ERROR = 13 ; P = '.' ; ASCII = reverse( x2c( 'FFFD' )) call value THIS... || 0, 0 /* STEM.0 = 0 if no .TYPE found */ call value THIS... || P, '' /* STEM.. = codepage if MULTI EA */ call SysGetEA arg( 1 ), arg( 2 ), 'VAL' if result <> 0 then return result if length( VAL ) = 0 then return 0 if length( VAL ) < 4 then return ERROR parse var VAL EAT 3 SIZE 5 . select /* handle ASCII as last MULTI EA */ when EAT == ASCII then LAST = 1 when EAT <> MULTI then return ERROR when length( VAL ) < 6 then return ERROR otherwise call value THIS... || P, c2d( reverse( SIZE )) parse var VAL . 5 LAST 7 VAL LAST = c2d( reverse( LAST )) end do N = 1 to LAST if length( VAL ) < 4 then return ERROR parse var VAL EAT 3 SIZE 5 VAL SIZE = c2d( reverse( SIZE )) if EAT <> ASCII then return ERROR if length( VAL ) < SIZE then return ERROR call value THIS... || 0, N call value THIS... || N, left( VAL, SIZE ) VAL = substr( VAL, SIZE + 1 ) end N if VAL == '' then return 0 /* really okay */ if VAL == d2c( 0 ) then return 1 /* almost okay */ else return ERROR /* extra bytes */ XEAT.PUTEA: procedure expose ( THIS... ) call UTIL 'SysPutEA' ; MULTI = reverse( x2c( 'FFDF' )) ERROR = 13 ; P = '.' ; ASCII = reverse( x2c( 'FFFD' )) LAST = value( THIS... || 0 ) ; VAL = '' ; N = 0 if symbol( THIS... || P ) = 'VAR' then do N = value( THIS... || P ) ; if N = '' then N = 0 end /* treat undefined codepage as 0 */ if datatype( LAST, 'w' ) = 0 then return ERROR if 10000 <= LAST | LAST < 0 then return ERROR if datatype( N , 'w' ) = 0 then return ERROR if 10000 <= N | N < 0 then return ERROR if LAST > 1 | N <> 0 then do /* use MULTI only if neccessary: */ N = reverse( x2c( d2x( N , 4 ))) SIZE = reverse( x2c( d2x( LAST, 4 ))) VAL = MULTI || N || SIZE /* x2c(d2x(X, 2*L)) <> d2c(X, L) */ end do N = 1 to LAST /* WPS accects / keeps void, but */ EAT = THIS... || N /* NOVALUE is definitely illegal */ if symbol( EAT ) <> 'VAR' then return ERROR EAT = value( EAT ) SIZE = reverse( x2c( d2x( length( EAT ), 4 ))) VAL = VAL || ASCII || SIZE || EAT end N /* empty VAL clears the EA .TYPE */ return SysPutEA( arg( 1 ), arg( 2 ), VAL ) 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 = '' 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 ) RENO: procedure /* try to change WPS object id.: */ call UTIL 'SysIni' /* returns error or void string */ call UTIL 'SysSetObjectData' ; call UTIL 'SysSaveObject' OLD = strip( arg( 1 )) ; parse var OLD O.1 '<' . '>' O.2 NEW = strip( arg( 2 )) ; parse var NEW N.1 '<' . '>' N.2 APP = 'PM_Workplace:Location' ; VAL = SysIni( 'USER', APP, OLD ) BAD = '";,' "'" xrange( x2c( 00 ), x2c( 1F )) select /* don't allow space etc. in id. */ when arg() <> 2 | (( O.1 || O.2 || N.1 || N.2 ) <> '' ) then return 'invalid object id.' OLD 'or' NEW when sign( verify( OLD || NEW, BAD, 'Match' )) then return 'unsupported char.:' OLD 'or' NEW when VAL = 'ERROR:' | VAL = '' then return APP OLD 'lost in space or invalid' when NEW = OLD /* nothing to do and id. checked */ then return '' when SysIni( 'USER', APP, NEW ) <> 'ERROR:' then return APP NEW 'already exists' when SysSetObjectData( OLD, 'OBJECTID=' || NEW ) <> 1 then return 'cannot set OBJECTID=' || NEW 'for' OLD when SysIni( 'USER', APP, NEW, VAL ) <> '' then return APP NEW 'not defined: fatal SysIni error' when SysSetObjectData( NEW, 'OBJECTID=' || NEW ) <> 1 then return 'cannot set OBJECTID=' || NEW 'for' NEW when SysIni( 'USER', APP, OLD, 'Delete:' ) <> '' then return APP OLD 'not deleted: fatal SysIni error' when SysSaveObject( NEW, 0 ) <> 1 then return APP NEW 'not saved: SysSaveObject error' otherwise return '' end BOOT: procedure /* presumably unused, deprecated */ call UTIL 'SysBootDrive' ; return SysBootDrive() SHOW: procedure expose LINE. /* try PM or ooREXX RxMessageBox */ R = lineout( LINE.. ) /* close whatever LOGfile LINE.. */ if PROC() = 3 then R = 25 /* assume max. 24 message lines */ if LINE.0 < 2 then return 0 if LINE.0 > R then return SHOW.DOWN() R = LINE.2 /* x2c(0) confuses RxMessageBox: */ do L = 3 to LINE.0 ; R = R || x2c( 0A ) || LINE.L ; end L R = translate( R, d2c( 248 ), x2c( 0 )) signal on syntax name SHOW.DOWN return RxMessageBox( R, LINE.1, 'OK', 'WARNING' ) SHOW.DOWN: /* no PM REXX or too many lines: */ do L = 1 to LINE.0 ; say LINE.L ; end L if PROC() < 3 then pull ; return 1 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 WARN: procedure /* try RxMessageBox, then STDERR */ parse source . . THIS ; signal on syntax name WARN.TRAP return ( RxMessageBox( arg( 1 ), THIS, /**/, 'HAND' ) <> 1 ) WARN.TRAP: parse version THIS . ; signal on syntax name TRAP if THIS = 'REXXSAA' /* fails if no more file handle: */ then return lineout( 'STDERR' , arg( 1 )) else return lineout( '\dev\con', arg( 1 )) OKAY: procedure /* get YES / NO / CANCEL answer: */ KEY = PROC() ; OUT = 'STDERR' YES = x2c( 0D ) || 'Y+1' ; NAY = x2c( 7F ) || 'N-0' AXE = x2c( 1B ) || 'X=k' /* F3 (003D) = / Alt-F4 (006B) k */ 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, 'YESNOCANCEL', 'QUERY' ) if KEY = 6 | KEY = 7 then return 7 - KEY ; else exit KEY end when KEY < 4 then call UTIL 'SysGetKey' otherwise nop /* 4 (detached) tested in AKEY() */ end call charout OUT, arg( 1 ) || ': ' do until sign( pos( KEY, 'YNX' )) call charout OUT, x2c( 7 ) ; KEY = translate( AKEY()) if pos( KEY, AXE ) > 0 then KEY = 'X' if pos( KEY, NAY ) > 0 then KEY = 'N' if pos( KEY, YES ) > 0 then KEY = 'Y' end call lineout OUT, KEY ; if KEY = 'Y' then return 1 if KEY = 'N' then return 0 ; exit 2 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 /* determine OS/2 process types: */ parse source OS . /* 0: full screen, 1: real mode, */ if OS = 'OS/2' then do /* 2: window, 3: PM, 4: detached */ call UTIL 'SysProcessType' ; return SysProcessType() end return OS <> 'WindowsNT' /* fake 0: NT, 1: DOS or unknown */ XENV: procedure /* DOS REXX portable environment */ parse version ENV . . if ENV = 'REXXSAA' then do parse source ENV . . /* OS/2 REXXSAA: os2environment */ if ENV = 'OS/2' then ENV = 'OS2ENVIRONMENT' else ENV = ENV || 'ENVIRONMENT' end /* DOS REXXSAA: DOSENVIRONMENT */ else ENV = 'ENVIRONMENT' /* REXX/Personal: environment */ select when arg() = 1 then return value( arg( 1 ),/* get */, ENV ) when arg() = 2 then return value( arg( 1 ), arg( 2 ), ENV ) otherwise return abs( /* force REXX error 40 */ ) end XDIR: procedure /* DOS REXX portable directory() */ parse source NN . ; if NN == 'DOS' then parse version NN . select when arg() > 1 then return abs( /** error 40 **/ ) when NN <> 'REXXSAA' & arg() = 0 then return directory() when NN <> 'REXXSAA' then return directory( arg( 1 )) when arg() = 0 then nop /* PC DOS REXXSAA get dir. */ otherwise /* PC DOS REXXSAA set dir. */ parse arg NN /* adding point D: => D:. */ if pos( ':', NN ) = length( NN ) then NN = NN || '.' if RxChDir( NN ) = 0 then do NN = left( NN, pos( ':', NN )) if NN <> '' then call RxChDrv NN end /* RxChDrv() error ignored */ else return '' /* RxChDir() failure => '' */ end return RxGetDrv() || RxGetDir() XRMD: procedure /* semi-portable SysRmDir() */ parse source KEY . . /* assuming ooREXX for WindowsNT */ if KEY = 'OS/2' | KEY = 'WindowsNT' then do call UTIL 'SysRmDir' return SysRmDir( arg( 1 )) <> 0 /* 0: okay, 1: error */ end parse version KEY . . if KEY = 'REXXSAA' then return RxRmDir( arg( 1 )) <> 0 /* 0: okay, 1: error */ else return DosRmDir( arg( 1 )) == 0 /* 0: okay, 1: error */ XDEL: procedure /* semi-portable SysFileDelete() */ parse source KEY . . /* assuming ooREXX for WindowsNT */ if KEY = 'OS/2' | KEY = 'WindowsNT' then do call UTIL 'SysFileDelete' return SysFileDelete( arg( 1 )) <> 0 /* 0: okay, 1: error */ end parse version KEY . . if KEY = 'REXXSAA' then return RxDelete( arg( 1 )) <> 0 /* 0: okay, 1: error */ else return DosDel( arg( 1 )) == 0 /* 0: okay, 1: error */ KWIK: /* quick sort: call KWIK 'stem.' */ if arg() <> 1 then return abs( /* REXX error 40 */ ) THIS... = arg( 1 ) /* abuse global THIS... as stem */ if right( THIS... , 1 ) <> . then THIS... = THIS... || . return KWIK.Y( THIS... ) /* expose THIS... stem */ KWIK.Y: procedure expose ( THIS... ) S = 1 ; SL.1 = 1 ; SR.1 = value( THIS... || 0 ) do until S = 0 L = SL.S ; R = SR.S ; S = S - 1 /* pop */ do while L < R I = ( L + R ) % 2 ; P = value( THIS... || L ) XR = value( THIS... || R ) if XR << P then do /* R...L */ call value THIS... || R, P call value THIS... || L, XR ; P = XR end /* L...R */ XI = value( THIS... || I ) XR = value( THIS... || R ) select when XI << P then do /* I L R */ call value THIS... || I, P call value THIS... || L, XI end /* L I R */ when XI >> XR then do /* L R I */ call value THIS... || R, XI call value THIS... || I, XR ; P = XR end /* L I R */ otherwise P = XI /* L I R */ end I = L + 1 ; J = R - 1 /* I...J */ if J <= I then leave /* ready */ do until I > J do while value( THIS... || I ) << P ; I = I+1 ; end do while value( THIS... || J ) >> P ; J = J-1 ; end if I <= J then do XI = value( THIS... || I ) call value THIS... || I, value( THIS... || J, XI ) I = I + 1 ; J = J - 1 end end /* I > J */ if J - L < R - I then do /* less left keys */ S = S + 1 ; SL.S = I ; SR.S = R ; R = J end /* pushed old R - I > 1 keys, now do L */ else do /* more left keys */ S = S + 1 ; SL.S = L ; SR.S = J ; L = I end /* pushed J - old L > 1 keys, now do R */ end /* R <= L */ end /* S == 0 */ return value( THIS... || 0 ) 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 */ if abbrev( TRAP.REXX, 'REXXSAA ' ) | /**/ , 6 <= word( TRAP.REXX, 2 ) then TRAP.REXX = 'STDERR' else TRAP.REXX = '\dev\con' signal on syntax name TRAP.FAIL call lineout TRAP.REXX , TRAP /* fails if no more handle */ end when 0 then do /* OS/2 PM or ooREXX on NT */ signal on syntax name TRAP.FAIL call RxMessageBox translate( TRAP, ' ', x2c( 0D )), /**/ , 'Trap' time(),, 'ERROR' end 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 */