\ IconJ utility; replacement for IconX \ Rich Franzen, 3 Feb 1990 \ JForth Professional v2.01 \ \ tool types: DELAY as per IconX \ WINDOW as per IconX, with WB-relative extensions \ PATHS [OFF|SMART] [NOQUOTES] [NOCROP] [METOO] \ SCRIPT identifies script location & type \ options: [(.|~)info] [REXX] [CLI] [VIEW] \ [STARTUP] \ \ Revision History \ 0.2 added full pathname generation \ 0.3 added relative window support and VIEW switch to SCRIPT= \ 0.4 added PATHS= tool type \ 0.41 @Window modified to open plain CON: window if 1st try fails \ 0.42 fixed FindToolType() to handle case of toolTypes=null \ 0.5 added METOO switch. \ added CleanExit. \ left ConsoleIn alone. \ changed call to execute() so that one param. always null. \ 0.6 added support for output to any file/device. \ added STARTUP switch to SCRIPT=. \ allowed use of resident execute/rx. \ reorganized switch sensing. \ implemented optional automatic closure of CLI windows. \ fixed WB 1.2 RAM: bug. \ fixed current directory bug (couldn't find cd without ARP) \ 0.61 fixed the fix to cd bug (acted improperly at :file level) \ 1.00 altered version number to reflect public release \ getmodule includes include? DiskObject ji:workbench/workbench.j include? WBstartup ji:workbench/startup.j include? GetDiskObject() ju:Icon-Support include? Lock() ju:dos-support anew task-IconJ : temps.txt ( -- a) " T:t/" ; \ default script directories : IconJ.txt ( -- a) " IconJ_" ; \ base of temp.script name : version ( -- a) " v1.00, Š1990 Rich Franzen" ; \ embedded Š : WINDOW.dflt ( -- a) 0" con:0/50/640/80/IconJ" ; \ default window : BL".txt ( -- a) 0" " ; \ 2 character string ascii " BL".txt 1+ c! \ force quote as second char : .txt ( -- a) 0" " ; \ 1 character string 10 .txt c! \ force as character 256 constant Bytes/Path \ max # of bytes allowed in pathname 255 constant maxLine \ max # of char's in execute() string \ used only when cropping variable ?unlock \ switch to control unlocking variable isConsole \ flag; true iff console output variable output0 \ original output stream variable DELAY= \ DELAY tool type value variable theDelay \ DELAY tool type address (or 0) variable wb_height \ workbench height variable wb_width \ workbench width variable wb_dim \ holds either wb_width or wb_height variable wi_top \ console top edge variable wi_left \ console left edge variable wi_height \ console height variable wi_width \ console width variable theIcon \ diskobject pointer variable theToolTypes \ tooltypes pointer variable theScript \ SCRIPT= address variable thePath \ PATHS= address variable myFIB \ location of FileInfoBlock variable myArgs \ location of argument list variable string.addr \ last address used variable conID \ console (or output file/device) filehandle variable fileID 40 allot \ storage for created file name \ 4-byte file_lock + 36 bytes file name for ID_Unique script file code 4+ ( n -- n4+) \ quick 4 + 4 # tos dn addq inline end-code code 8* ( n -- 4n) \ multiply by 8 quickly 3 # tos dn asl inline end-code code 4* ( n -- 4n) \ multiply by 4 quickly 2 # tos dn asl inline end-code code >Boolean ( n -- f) \ convert number to Boolean flag tos dn long tst \ evaluate TopOfStack tos dn byte sne \ set bottom byte to FF or 00; FF when non-zero tos dn word ext tos dn long ext \ extend bottom byte to 32 bits both end-code : delay() ( n) \ wait for n ticks, 50 ticks/sec callvoid dos_lib delay ; : DeleteFile() ( aa_0$) \ dos_lib delete callvoid dos_lib DeleteFile ; : execute() ( aa_0$ in out -- f) \ execute a command string call dos_lib execute ; : unlock() ( lock) \ free a lock; dos-support form callvoid dos_lib UnLock ; \ contains unnecessary overhead : GetScreenData() ( aa size type screen -- f) \ acquire screen info call intuition_lib GetScreenData ; : FindToolType() ( a_toolTypes a_typeName -- a_0$|ff) over if call>abs icon_lib FindToolType if>rel else drop \ prevents fatal crash if a_toolTypes is NULL then ; : MatchToolValue() ( a_stringPointer a_subString -- f) call>abs icon_lib MatchToolValue ; \ WBMessage Arguments: \ 1st will always be default tool \ 2nd will be main (sometimes calling) project \ 3rd & subsequent will be follow-on projects : @ArgList ( -- a) \ fetch addr of workbench argument list wbmessage @ if>rel ..@ sm_ArgList if>rel ; : @Arg ( n -- a) \ fetch address of nth argument 8* @ArgList + ; : WB#Args ( -- n) \ return # of WB arguments wbmessage @ if>rel ..@ sm_NumArgs ; : ArgName ( n -- a) \ return absolute addr of specified name @Arg 4+ @ if>rel ; : SetDir ( n) \ set directory to that of calling icon @Arg @ ( -- directory_lock) ?dup if dup WBLock ! callvoid DOS_lib CurrentDir then ; : CLI_Abort wbmessage @ \ abort job if CLI task 0= abort" This command is used from WorkBench only." ; : NoProject_Abort \ abort w/o comment if no project WB#Args 2 < if abort then ; : @Paths \ find & store PATH= address theToolTypes @ 0" PATHS" FindToolType() thePath ! ; : MTV_Paths ( f1 a_0$ -- f2) \ MatchToolValuePaths thePath @ dup if swap MatchToolValue() nip else 2drop then ; : ?PATHS ( -- f) \ use paths with filenames? false 0" OFF" MTV_Paths 0= ; : ?SMART ( -- f) \ use pathnames just on 1st occurances? false 0" SMART" MTV_Paths ; : ?QUOTES ( -- f) \ include quotes in pathname(s)? false 0" NOQUOTES" MTV_Paths 0= ; : ?CROP ( -- f) \ crop execute() string? false 0" NOCROP" MTV_Paths 0= ; : ?METOO ( -- f) \ include self as an argument? false 0" METOO" MTV_Paths ; : @Script \ find & store SCRIPT= address theToolTypes @ 0" SCRIPT" FindToolType() theScript ! ; : MTV_Script ( f1 a_0$ -- f2) \ MatchToolValueScript theScript @ dup if swap MatchToolValue() nip else 2drop then ; : ?.info ( -- f) \ is it a self-contained script? false 0" .info" MTV_Script ; : ?~info ( -- f) \ is it a normal .info-mate script? true 0" ~info" MTV_Script ; \ eg script for Fred.info = Fred : ?(CLI) ( -- f) \ is it an interactive script? false 0" CLI" MTV_Script ; \ must be checked later against isConsole : ?REXX ( -- f) \ is it a Rexx script? false 0" REXX" MTV_Script ; : ?STARTUP ( -- f) \ execute s:IconJ-Startup? false 0" STARTUP" MTV_Script ; : ?VIEW ( -- f) \ view command string? false 0" VIEW" MTV_Script ; : ?CLI ( -- f) \ insure CLI is only applied to consoles ?(CLI) isConsole @ and ; : @Delay \ set delay from disk object theToolTypes @ 0" DELAY" FindToolType() theDelay ! ; : @!Delay \ store delay parameter @Delay theDelay @ ?dup if 0. rot 1- convert 2drop 1 max DELAY= ! \ if tool exists else ?CLI if 1 else 100 then DELAY= ! \ if tool absent then ; : $Get-Icon ( a_0$) \ bring diskobject into memory GetDiskObject() dup theIcon ! ..@ do_ToolTypes if>rel theToolTypes ! ; : Free-Icon \ free diskobject theIcon @ ?dup if FreeDiskObject() theIcon off then -icon ; : GetMem ( n -- a) \ get a block of public memory MemF_Public MemF_Clear or swap AllocBlock dup 0= abort" Insufficient memory. " ; : PutMem ( a) \ release a block of memory ?dup if FreeBlock then ; : GetFIB \ get memory for FileInfoBlock sizeof() FileInfoBlock GetMem MyFIB ! ; : PutFIB \ release FIB memory MyFIB @ PutMem MyFIB off ; : GetArgMem \ get memory for arguments (256 bytes per) WB#Args ?CROP if drop 2 then Bytes/Path w* GetMem myArgs ! ; : PutArgMem \ release argument memory myArgs @ PutMem myArgs off ; : Delete?File \ delete temporary script file fileID @ if fileID 4+ >abs DeleteFile() then fileID off ; : CloseConsole \ "safe" closing of console window conID @ ?dup if FClose then conID off ; : CleanExit \ insure everything gets released on aborts Delete?File PutArgMem PutFIB CloseConsole Free-Icon ; : nTool ( n -- aa) \ return absolute pointer to nth ToolType 4* theToolTypes @ + @ ; : 1stLine ( -- n) \ find nth tool, which contains SCRIPT= theScript @ 7 - >abs ( aa_of_SCRIPT_tool) >r -1 Begin 1+ dup nTool r@ = until rdrop ; : xfrLine ( a_0$) \ transfer line from *.info to ID_Unique fileID @ swap 0count fwrite 0< abort" Unable to transfer line. " fileID @ 10 femit ; : xfrScript 1stLine \ transfer all lines to ID_Unique begin 1+ dup nTool if>rel ?dup while xfrLine repeat drop fileID @ dup unmarkfclose fclose ; : ID_Unique no-commas \ make a unique file ID IconJ.txt count +DOS \ assume string already started (T: etc) 0 >abs 36 base ! n>text +DOS decimal ; : tryOpen ( -- handle|ff) \ attempt to open a file MODE_NEWFILE ID_Unique new DOS0 0fopen ; : .infoScript \ create a temporary script file temps.txt 1+ 2 >DOS tryOpen \ T:ID_Unique ?dup if-not temps.txt 2+ 3 >DOS tryOpen then \ :t/ID_Unique ?dup if-not dosstring off tryOpen then \ ID_Unique ?dup if-not " RAM:" count >DOS tryOpen then \ RAM:ID_Unique ?dup if-not abort then \ we tried... fileID ! DOS0 0count fileID 4+ swap 1+ cmove fileID @ markfclose ; : ~infoScript fileID off \ identify non-.info script file ?~info if 1 argname 0count else theScript @ 0count \ strip off anything from | onward 2dup ascii | scan nip - then fileID 4+ swap dup>r cmove 0 fileID 4+ r> + c! ( place null at end of string) ; : ScriptName \ store final script name at fileID 4+ ?.info if .infoScript xfrScript else ~infoScript then ; \ interpret relative con: window spec : crop ( n min max -- n|min|max) \ crop n between min & max rot min max ; : *% ( dim %n -- scaled_dim) \ take n% of dim, dpl known >0 * dpl @ 0 do 10 / loop ; : get_w&h intuition? \ get workbench width & height myFIB @ >abs 16 WBenchScreen 0 GetScreenData() 0= abort" Unable to acquire screen sizes. " myFIB @ dup ..@ sc_width wb_width ! ..@ sc_height wb_height ! -intuition ; : >$Num ( a1 -- a2 a1 | ff) \ convert :# or /# to Forth numeric string dup>r 1+ 9 ascii / scan dup if negate 9 + r@ c! r> else 2drop rdrop 0 then ; : #dim ( a -- n|tf) \ left edge, width, top edge, or height number? if drop >r dpl @ 0> if wb_dim @ r> *% >r then \ 1st, do % dpl @ 0= if rdrop wb_dim @ >r then \ 2nd, check 1. r@ 0< if wb_dim @ r> + >r then \ 3rd, do neg r> 0 wb_dim @ crop \ 4th, crop else -1 \ non-number flag then ; : #left ( a) \ calculate left edge wb_width @ wb_dim ! #dim 0 max wi_left ! ; : #width ( a) \ calculate width wb_width @ wb_dim ! #dim 50 max wi_width ! ; : #top ( a) \ calculate top edge wb_height @ wb_dim ! #dim 0 max wi_top ! ; : #height ( a) \ calculate height wb_height @ wb_dim ! #dim 20 max wi_height ! ; : valid_l&w \ insure left+width <= wb_width wb_width @ wi_left @ - wi_width @ - dup 0< if wi_left +! else drop then ; : valid_t&h \ insure top+height <= wb_height wb_height @ wi_top @ - wi_height @ - dup 0< if wi_top +! else drop then ; : GetWin#s ( a1 -- a2|ff) \ parse #'s in CON: spec between : & last / get_w&h >$Num dup if-not EXIT then #left >$Num dup if-not EXIT then #top >$Num dup if-not EXIT then #width >$Num dup if-not EXIT then #height valid_l&w valid_t&h ; : PutWin# ( n) \ transfer one # to dos buffer n>text +dos 0" /" 1 +dos ; : PutWin#s \ convert valid numbers back to CON: strings no-commas wi_left @ PutWin# wi_top @ PutWin# wi_width @ PutWin# wi_height @ PutWin# ; : a_WINDOW= ( -- a_0$|0) \ get address of WINDOW= theToolTypes @ 0" WINDOW" FindToolType() ; : a_file|dev ( -- a_0$) \ perform a_WINDOW= & do non-Console stuff a_WINDOW= isConsole off \ output will not be to console new ; \ set mode_newfile for subsequent 0Fopen : WINDOW.parse ( a_src -- a_end) \ parse a CON: spec 0count pad swap cmove \ move name to work buffer pad dup 20 ascii : scan ( a_src2 a_of_: char's_left|ff) ?dup if swap >r negate 20 + 1+ >dos \ "CON:" text or equivalent r> GetWin#s ?dup if PutWin#s 1+ 0count +dos dos0 else a_file|dev \ if CON: doesn't parse right then ( dos0 | a_WINDOW=) else 2drop a_file|dev \ if no ":" in window spec then ; : @Window \ open console window isConsole on \ assume CON: window a_WINDOW= ?dup if WINDOW.parse else WINDOW.dflt then 0FOpen ?dup if-not isConsole on \ will be a console window WINDOW.dflt 0FOpen \ try a 2nd time ?dup if-not abort then \ when CON: not available then conID ! ; \ build complete pathnames with average pathname length < 256 chars : LockIs ( lock -- fl_Key fl_Volume) \ get a lock's block# & volume # 4* >rel dup>r ..@ fl_Key r> ..@ fl_Volume ; : ?Lock= ( lock1 lock2 -- f) \ determine if locks represent same item LockIs rot LockIs d= ; : cmdstring ( -- a) \ return base addr of command buffer myArgs @ ; : cmd0 \ return base addr of command string cmdstring 2+ ; : +cmd ( adr cnt) \ move string to command buffer dup>r cmd0 ( src_adr cnt cmd_base) cmdstring w@ + ( src_adr cnt cmd_end) swap 2dup + >r ( save end addr ) ( fr to cnt -- ) cmove 0 r> c! ( null-terminate it!) cmdstring dup w@ r> + swap w! ( inc the text forth cnt ) ; : >cmd ( adr cnt) \ initialize command buffer with text cmdstring off +cmd ; : _+cmd ( adr cnt) \ +cmd, but appends BL before string BL".txt 2 +cmd +cmd \ and surrounds string with quotes BL".txt 1+ 1 +cmd ; : BL+cmd ( adr cnt) \ +cmd, but appends BL before string BL".txt 1 +cmd +cmd ; : +cmd ( adr cnt) \ +cmd, but append before string .txt 1 +cmd +cmd ; DEFER !cmd \ deferred word to xfr text : !cmd? ( adr cnt -- f) \ !cmd with optional cropping ?CROP if cmdstring w@ >r \ save for restoration of null !cmd cmdstring w@ maxLine > dup if r@ cmdstring w! 0 r@ cmd0 + c! \ restore string pointers then rdrop else !cmd false then ; : .version \ type version # f:3 IconJ.txt count 1- type space version count type f:1 cr ; : .view \ view command string .version cmd0 cmdstring w@ type cr cr ; : next.addr ( cnt -- adr) \ compute location for next string 1+ negate \ leave room for null string.addr @ + dup string.addr ! ; : path_segment ( lock -- a_0$) \ get lock's text name myFIB @ Examine() 0= abort" Unable to build pathname. " myFIB @ .. fib_FileName ; : path_init ( n) \ initialize pathname with nth filename myArgs @ dup SizeMem + 1- string.addr ! ArgName 0count dup next.addr swap 1+ cmove ?unlock off ; : root_colon \ write : after root name myFIB @ .. fib_FileName c@ BL < if 0" RAM:" 0count \ for WB1.2, which didn't have dup next.addr 1+ swap cmove \ rootname for ramdisk 1 string.addr +! \ since ":" already present else string.addr @ 81 ascii / scan ( adr cnt) \ find 1st "/" if ascii : swap c! else drop then then ; : FileName ( n -- f) \ xfr filename without path-spec ArgName 0count !cmd? ; : PathName ( n -- f) \ build pathname for nth argument dup path_init @Arg @ ( lock) Begin dup path_segment 0count ( lock a_0$ cnt) dup if string.addr @ 1- >r \ save connector address dup next.addr swap cmove ascii / r> c! \ store connector else 2drop \ case of RAM: & WB1.2 then ( lock) dup>r ParentDir() ( Parent_lock) ?unlock @ if r> unlock() else rdrop ?unlock on then ?dup 0= until root_colon string.addr @ 0count !cmd? ; : SmartPath ( n -- f) \ build pathname only when path 1st in seq. dup>r 3 < if r@ PathName \ always use full path on 1st args. else r@ @Arg @ r@ 1- @Arg @ ( lock_n lock_n-1) ?Lock= if r@ FileName else r@ PathName then then rdrop ; : BuildPath ( n -- f) \ build pathname using ?PATHS and ?SMART ?PATHS if ?SMART if SmartPath else PathName then else FileName then ; : ?CD: ( a c -- a ff | a+1 tf) \ keep : as part of CD string ascii : = if 1+ TRUE else FALSE then ; : myCD \ init execute() string with CD to cd 0" CD" 2 >cmd \ initialize execute() string 1 PathName drop \ build full pathname for 1st arg cmd0 cmdstring w@ + \ find last ":" or "/" begin 1- dup c@ dup>r ?CD: r> ascii / = or until ?QUOTES if ascii " over c! 1+ then \ enplace 2nd quote 0 swap c! \ chop-off filename portion cmd0 0count cmdstring w! drop ; \ update string count : Command ( -- a_0$) \ build command string ?QUOTES if ' _+cmd else ' BL+cmd then is !cmd myCD \ this is necessary kludge on non-ARP systems ?STARTUP if " Execute s:IconJ-Startup" count +cmd then ?REXX if " Rx " else " Execute " then \ dos command count +cmd fileID 4+ 0count +cmd \ scriptname ?METOO if 1 PathName drop then \ include self? wb#args 2 > if \ include others? wb#args 2 do i BuildPath if leave then loop then ?CLI theDelay @ >Boolean \ if interactive, but delay specified and if " EndCLI" count +cmd then cmd0 ; : IconJ \ top level command CLI_Abort NoProject_Abort \ when there's nothing to do ' CleanExit IS ErrorCleanUp \ try to insure clean aborts ConsoleOut @ output0 ! \ save original i/o 1 SetDir 1 ArgName $Get-Icon \ setup environment GetFIB \ get work/FIB buffer @Window @Script @Paths @!Delay \ gather information conID @ ConsoleOut ! \ place for error messages GetArgMem \ create memory buffer for command ScriptName Command >abs \ build command string ?View if .View then \ type command string 0 conID @ ?CLI if swap then \ set i/o for con: (1 param = 0!) Free-Icon PutFIB \ free-up icon and FIB mem ( aa_0$ IN OUT) execute() drop \ (R)execute script PutArgMem \ free-up memory buffers DELAY= @ delay() \ wait user-specified time CloseConsole \ close console window Delete?File \ delete temporary file, if nec. output0 @ ConsoleOut ! ;