\ AtatJ coUtility for use in IconJ environment \ Rich Franzen, 3 Feb 1990 \ JForth Professional v2.01 \ \ Revision History \ 0.2 added -dd option \ 0.3 added CleanExit word, deferred as ErrorCleanUp \ 0.31 made work buffer bigger & had Free-Icon close icon.library \ 0.4 added -s option & fixed FindToolType for null tooltypes \ 0.41 fixed .Command to properly show filepaths with spaces \ 1.00 altered version number to reflect general 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-AtatJ 256 constant max_line \ maximum script line length variable op_detach \ detach flag variable op_REXX \ REXX flag variable op_CLI \ CLI flag variable op_STARTUP \ STARTUP flag variable myFIB \ storage for pointer to FIB variable theToolTypes \ storage for ToolTypes pointer variable theStrings \ storage for new ToolType array + strings variable theScript \ storage for SCRIPT= address variable string.addr \ last location used for string text variable tool# \ last tool number used variable +Script \ offset within TIB to ScriptName variable Script_handle \ handle for ScriptName variable +Info \ offset within TIB to InfoName variable Info_handle \ address of InfoFile memory buffer code 4+ ( n -- n4+) \ quick 4 + 4 # tos dn addq inline end-code code 4* ( n -- n4*) \ multiply by 4 quickly 2 # tos dn asl inline end-code : ?0() ( addr count -- adr2 | ff) \ determine if range contains a 0 false -rot \ assume no 0 is present dup if over + swap do i c@ 0= if drop i leave then loop else 2drop \ case of 0-length string then ; : .Tab 9 emit ; \ print tab character : .Command \ print command name tib +Script @ type ; : .Usage \ print usage message f:3 .Command ." v1.00 by Rich Franzen, © 1990" f:1 cr ." Attaches a script to a project icon (xyz.info) file." cr cr ." Usage: " .Command ." ScriptFile [InfoFile] [-(r|c|s|d|dd)]" cr .Tab ." use r switch when ScriptFile is ARexx script" cr .Tab ." use c switch when ScriptFile requires keyboard input" cr .Tab ." use s switch when s:IconJ-Startup is to be executed also" cr .Tab ." use d switch when detaching script from InfoFile" cr .Tab ." use dd switch when duplicating script from InfoFile" cr ; : .infoExit .usage quit ; \ report info and exit : ScriptFile ( -- a_0$) \ returns address of ScriptFile name TIB +Script @ + ; : InfoFile ( -- a_0$) \ returns address of InfoFile name TIB +Info @ + ; : ScriptName \ get ScriptFile name from TIB >in @ +Script ! \ save offset within TIB fileword dup oddw@ $ 013F = if drop .infoExit then \ when ? dup c@ if count dup>r ScriptFile swap cmove \ normal 0 ScriptFile r> + c! \ 0-terminate the string else drop .infoExit \ when zip then ; : switches_off \ initialize switches to off op_detach off op_REXX off op_CLI off op_STARTUP off ; : parse_switch ( c) \ parse single character of switch field $ df and case ascii D of -1 op_detach +! endof \ checks for double D's ascii R of op_REXX on endof ascii C of op_CLI on endof ascii S of op_STARTUP on endof endcase ; : @Switches ( a$) \ get switches from TIB count over c@ ascii - = over 1 > and if over + swap 1+ do i c@ parse_switch loop else 2drop then ; : Script>Dest \ set DestInfoFile = ScriptFile +Script @ +Info ! ; : InfoName \ get DestInfoFile name and @Switches >in @ +Info ! \ save offset within TIB switches_off \ initialize command switches fileword dup c@ 0= if \ 2nd parameter absent Script>Dest drop else \ 2nd parameter present dup 1+ c@ ascii - = if \ 2nd parameter is switches @Switches Script>Dest else \ 2nd parameter is InfoName count dup>r InfoFile swap cmove 0 InfoFile r> + c! fileword @Switches \ here for balanced activity then then ; : strip.info \ strips ".info" from InfoFile 0string 0" .info" 5 \ addr count InfoFile 0count + 5 - dup>r \ addr of last 5 bytes of InfoFile text=? if 0 r@ c! then rdrop ; : FindToolType() ( a_toolTypes a_typeName -- a_0$) over if call>abs icon_lib FindToolType if>rel else drop then ; : MatchToolValue() ( a_stringPointer a_subString -- f) call>abs icon_lib MatchToolValue ; : $Get-Icon ( a_0$) \ bring diskobject into memory GetDiskObject() dup Info_handle ! dup 0= abort" Unable to open the ICON file." ..@ do_ToolTypes if>rel theToolTypes ! ; : Free-Icon \ free diskobject Info_handle @ ?dup if FreeDiskObject() Info_handle off then -icon ; \ close icon.library : $Save-Icon ( a_0$) \ store diskobject onto disk Info_handle @ ?dup if PutDiskObject() then 0= if ." Error while saving DiskObject. " then Free-Icon ; : ?abort~proj \ abort if icon not project type Info_handle @ ..@ do_Type WBPROJECT - if Free-Icon ." ICON file is not type PROJECT. " abort then ; : @ScriptFile ( a_0$) \ open ScriptFile ScriptFile 0fopen dup Script_handle ! dup 0= abort" Unable to open the ScriptFile." MarkFclose ; : !ScriptFile \ close ScriptFile Script_handle @ dup unmarkfclose fclose ; : GetMem ( n) \ allocate n bytes of memory Memf_Public Memf_Clear or swap AllocBlock dup 0= abort" Insufficient memory." theStrings ! ; : PutMem \ return memory theStrings @ ?dup if FreeBlock theStrings off then ; : GetFIB \ allocate a File Info Block MemF_Public sizeof() FileInfoBlock AllocBlock dup 0= abort" Insufficient memory." MyFIB ! ; : PutFIB \ free FIB MyFIB @ ?dup if FreeBlock MyFIB off then ; : CleanExit \ insure everything gets released on aborts Free-Icon PutMem PutFIB ; : nTool ( n -- aa) \ return addr of pointer to nth ToolType 4* theToolTypes @ + ; : find_SCRIPT \ find & store SCRIPT= address theTooltypes @ 0" SCRIPT" FindToolType() theScript ! ; : ?.info ( -- f) \ is it a self-contained script? false theScript @ ?dup if nip 0" .info" MatchToolValue() then ; : 1stLine ( -- n) \ find nth tool, which contains SCRIPT= theScript @ 7 - >abs ( aa_of_SCRIPT_tool) >r -1 Begin 1+ dup nTool @ dup 0= swap r@ = or until rdrop ; \ alternatively finds 1st blank slot : xfrLine ( a_0$) \ transfer line from *.info to ScriptFile Script_handle @ swap 0count fwrite 0< abort" Unable to transfer line." Script_handle @ 10 femit ; : xfr>Script \ transfer all lines to ScriptFile 1stLine begin 1+ dup nTool @ if>rel ?dup while xfrLine repeat drop ; : ExistsScript? \ if ScriptFile exists, delete it? ScriptFile Access_Read Lock() ?dup if unLock() cr F:3 ScriptFile 0count type F:1 ." already exists. Overwrite it (y/N)? " key BL or ascii y = 0= Abort" Ok, terminating." then ; : ScriptSize ( -- n) \ return size in bytes of ScriptFile ScriptFile Access_Read Lock() ?dup 0= abort" Unable to Lock() on ScriptFile." dup myFIB @ examine() 0= abort" Unable to Examine() ScriptFile." unLock() myFIB @ ..@ fib_Size ; : next.addr ( count -- addr) \ compute location for next string 1+ negate \ leave room for null string.addr @ + dup string.addr ! ; : next.tool ( -- # of next free tool) tool# @ 1+ dup tool# ! ; : !Tool ( addr count) \ store next tool dup next.addr dup>r swap dup>r cmove \ xfr name to theStrings 0 r> r> + c! \ null terminate string string.addr @ >abs next.tool nTool ! ; \ store string pointer : xfrTools \ move tools from old to new location theToolTypes @ dup if \ transfer any that exist theStrings @ 1stLine dup>r cells move else >r \ when noToolTypes then theStrings @ theToolTypes ! \ don't need orig. tooltype array " SCRIPT=.info" count >dos \ build new SCRIPT= tooltype op_Rexx @ if " |REXX" count +dos then op_CLI @ if " |CLI" count +dos then op_STARTUP @ if " |STARTUP" count +dos then theStrings @ dup sizemem + 1- string.addr ! \ init string.addr r> 1- tool# ! \ init tool# dos0 0count !Tool ; : .Early ( addr count) \ explain early exit cr ." Early exit due to: " dup max_line = if cr .tab ." line size too large. " then ?0() if cr .tab ." ascii null within ScriptFile. " then tool# @ negate tool# ! ; \ to remember about early exit : xfr