/* REXX: delete specified directory tree (r/w files), can run in */ /* DOS, VIO, PM, or detached session. The special case XDEL "." */ /* to delete all files and subdirectories of CWD won't result in */ /* an error. Exit code 0: okay, 1: trouble. */ signal on novalue name TRAP ; signal on syntax name TRAP signal on failure name TRAP ; signal on halt name TRAP SHOW = PROC() < 3 THIS = strip( strip( strip( arg( 1 )),, '"' )) if arg() <> 1 | THIS = '' then do /* expect 1 non-empty arg. */ parse source THIS /* exit if PM or detached: */ if SHOW = 0 then exit WAIT( 'error:' THIS ) say THIS '"directory"' say ' deletes "directory" recursively as far as possible:' say ' hidden, system, or read-only files are not deleted.' say 'Caveat: RMDIR and consequently this script too ignores' say ' the attributes of directories, i.e. empty read-only' say " directories are removed. It's impossible to remove" say ' the current working directory or its predecessors.' exit 1 end FAIL = SUBS( THIS ) if SHOW then call charout /**/, x2c(0D) left( '', 77 ) x2c(0D) if FAIL then exit WAIT( 'not removed:' THIS ) if XRMD( THIS ) = 0 then do if SHOW then say 'all deleted:' THIS ; exit 0 end FAIL = XDIR() if XDIR( THIS ) = FAIL then do if SHOW then say 'not removed:' FAIL ; exit 0 end exit WAIT( 'unexpected:' FAIL '<>' THIS ) SUBS: procedure expose SHOW call TREE arg( 1 ) || '\*', 'TREE', 'DO' if result <> 0 then exit TRAP( 'TREE DO' result ) rc = 0 do I = 1 to TREE.0 /* process subdirectories: */ if SUBS( TREE.I ) then do /* no more message - error */ rc = 1 ; iterate I /* already shown by SUBS() */ end if XRMD( TREE.I ) then do /* unexpected RMDIR error: */ rc = WAIT( 'not removed:' TREE.I ) if rc = 0 then exit 1 /* error and WAIT aborted: */ end /* default if detached */ else if SHOW then call charout /**/, '.' end I call TREE arg( 1 ) || '\*', 'TREE', 'FO' if result <> 0 then exit TRAP( 'TREE FO' result ) do I = 1 to TREE.0 /* process this directory: */ if XDEL( TREE.I ) then do /* locked or r/o file etc. */ rc = WAIT( 'not deleted:' TREE.I ) if rc = 0 then exit 1 /* error and WAIT aborted: */ end /* default if detached */ end I return rc /* see , (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 /* 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 */ 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 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 */ 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 */ 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 */