\ ReplaceTool.f 2.02 \ Program to change the default tool of a number project icons simultaneously, \ using the Workbench and Intuition. \ Written in JForth Professional 2.0 \ \ (c) Copyright 1989, 1990 by Richard Mazzarisi \ All rights reserved. \ \ address: \ 891 Post St. #207 \ San Francisco, CA \ 94109 \ \ email: \ rich@californium.cchem.berkeley.edu \ rmazz@hydrogen.cchem.berkeley.edu \ nmr@garnet.berkeley.edu \ \ \ 5/20/90 \ \ v. 1.00 9/2/89 \ v. 1.01 10/9/89 order of clicking icons no longer matters \ v. 2.00 2/1/90 added arp file requester if no tool clicked \ v. 2.01 3/22/90 fixed problem with final slash in drawer names from WB; if \ a drawer was selected prog does error exit \ (not a problem with JazzBench) \ 3/24/90 fixed problem similar to '/' with ':' on device icons \ 3/25/90 moved arp library openning away from startup - it is not \ needed unless no tool icon is selected; no need to \ abort if user clicks on a tool along with projects \ v. 2.02 5/15/90 fixed the tendency to crash if the arp file req returns \ a null string for the drawer \ 5/20/90 fixed the ability to find the font size and use this info \ in opening the window \ \ Instructions: \ 1 - Click on the icon for this program. \ 2 - Shift click on the Project icons to have their \ DefaultTool changed and the icon for the Tool to be \ set as the DefaultTool. \ 3 - OR shift click only on Project icons; a file requester will \ appear allowing the DefaultTool to be selected. \ \ (NOTE: The author assumes no responsibility for any damages \ resulting from the use of this program.) INCLUDE? CLONE CL:TOPFILE INCLUDE? LIBRARIES_DOS_H JI:LIBRARIES/DOS.J INCLUDE? LIBRARIES_DOSEXTENS_H JI:LIBRARIES/DOSEXTENS.J INCLUDE? EXEC_MEMORY_H JI:EXEC/MEMORY.J INCLUDE? TASK-AMIGA_GRAPH JU:AMIGA_GRAPH INCLUDE? TASK-AMIGA_EVENTS JU:AMIGA_EVENTS INCLUDE? TASK-CONSOLESUPPORT JU:CONSOLESUPPORT INCLUDE? TASK-ANSISUPPORT JU:ANSISUPPORT INCLUDE? TASK-DOS-SUPPORT JU:DOS-SUPPORT INCLUDE? TASK-AUTO_REQUEST JU:AUTO_REQUEST INCLUDE? TASK-SET-ICON JU:SET-ICON INCLUDE? TASK-LOCALS JU:LOCALS INCLUDE? LIBRARIES_ARPBASE_H JARP:ARPBASE.J INCLUDE? TASK-ARP_SUPPORT JARP:ARP_SUPPORT .NEED clone-it \ *** clone controller *** VARIABLE clone-it clone-it OFF .THEN ANEW task-replacetool DECIMAL \ *** constants *** \ # bytes to be allocated for the path string; biggest string which can \ be returned from arp filerequester LONG_DSIZE LONG_FSIZE + 1+ CONSTANT pathsize \ *** variables *** VARIABLE toolarg \ holds the position of the Tool arg \ *** console stuff *** \ variables to hold the request and reply ports VARIABLE wreq VARIABLE rreq VARIABLE wreply VARIABLE rreply : con.cr ( -- ) wreq @ $ 0A ConPutChar() ; : con.write ( straddr -- ) wreq @ SWAP COUNT ConWrite() ; : con.write.c3 ( straddr -- ) \ write string in color 3 1 33 2 CRender3 wreq @ >ANSIDEVICE con.write 0 1 CRender3 wreq @ >ANSIDEVICE ; : con.write.itl ( straddr -- ) \ write string in bold italics 3 1 2 CRender3 wreq @ >ANSIDEVICE con.write 0 1 CRender3 wreq @ >ANSIDEVICE ; : clear.line ( -- ) \ clear current line 0 CDeleteLine wreq @ >ANSIDEVICE ; : cursor.off ( -- ) \ get rid of cursor 0 CCursOff wreq @ >ANSIDEVICE ; \ *** main window stuff *** CREATE scr-buff Sizeof() Screen ALLOT NewWindow rt-window : getWBscreendata ( -- ) scr-buff Sizeof() Screen WBENCHSCREEN NULL CALL>ABS INTUITION_LIB GetScreenData NULL = IF ABORT" Could not get Workbench screen data." THEN ; : set.vert-params ( topedge #lines -- topedge' height ) \ calc window height, adjust topedge if necessary scr-buff ..@ sc_Font \ get font >REL ..@ ta_YSize \ font height \ estimate height from #lines, title bar height and lower border * scr-buff ..@ sc_BarHeight + 12 + \ check if too high 2DUP + scr-buff ..@ sc_Height > IF \ try adjusting topedge SWAP DROP \ lose old topedge scr-buff ..@ sc_Height OVER - DUP 0< IF \ not going to work; set to 0 & screen height 2DROP 0 scr-buff ..@ sc_Height ELSE SWAP THEN THEN ; : set.horiz-params ( leftedge #chars -- leftedge' width ) \ calc window width, adjust leftedge if necessary scr-buff .. sc_RastPort ..@ rp_TxWidth \ get font width \ estimate width from #chars, and borders * 24 + \ check if too wide 2DUP + scr-buff ..@ sc_Width > IF \ try adjusting leftedge SWAP DROP \ lose old leftedge scr-buff ..@ sc_Width OVER - DUP 0< IF \ not going to work; set to 0 & screen width 2DROP 0 scr-buff ..@ sc_Width ELSE SWAP THEN THEN ; : open.rt-window ( -- window/null ) getWBscreendata rt-window NEWWINDOW.SETUP 20 20 set.vert-params rt-window ..! nw_Height rt-window ..! nw_TopEdge 20 55 set.horiz-params rt-window ..! nw_Width rt-window ..! nw_LeftEdge 0" ReplaceTool 2.02" >ABS rt-window ..! nw_Title CLOSEWINDOW rt-window ..! nw_IDCMPFlags WINDOWCLOSE WINDOWDRAG | WINDOWDEPTH | WINDOWSIZING | rt-window ..! nw_Flags rt-window GR.OPENCURW ; : wait.close ( -- ) BEGIN GR-CURWINDOW @ EV.WAIT GR-CURWINDOW @ EV.GETCLASS CLOSEWINDOW = UNTIL ; \ *** string stuff *** CREATE pathstr pathsize ALLOT \ holds path to be put into Icons : init.name ( dest -- ) 0 SWAP ! ; : build.name ( addr count dest -- ) \ build string in buffer at dest, must init to null with init.name before \ using this word for the first time in building a new path name \ check for a non null in first place DUP @ 0= IF \ it was just initialized so just copy >$ ELSE $APPEND THEN ; \ *** resource management *** : close.rt-things ( -- ) con.cr " Click CloseBox to exit." con.write wait.close wreq @ 0= NOT IF wreply @ wreq @ rreply @ rreq @ ReleaseConsole() wreq OFF THEN GR.CLOSECURW GR.TERM \ close graphics -ARP \ and arp.library if it was used ; : rt.abort ( -- ) con.cr close.rt-things ABORT ; : open.rt-things ( -- t/f ) \ The error messages are for debugging under the interpreter; they won't \ be able to be seen under the workbench. GR.INIT \ open graphics wreq OFF GR-CURWINDOW OFF \ open window open.rt-window NULL = IF -ARP ABORT" Could not open a window!" THEN \ make it a console GR-CURWINDOW @ GetConsole() NULL = IF close.rt-things ABORT" Could not create a console device!" ELSE rreq ! rreply ! wreq ! wreply ! cursor.off THEN ; \ *** modified words from JU:SET-ICON *** \ these must not call ?ABORT" but must use rt.abort to clean up \ (probably don't need most of the error messages but leave them for \ debugging from the interpreter) : rt.icon-open? ( -- , just checks for 0 ) theIcon @ 0= IF " ERROR: No Icon selected ... use GET-ICON" con.write.itl con.cr rt.abort THEN ; : rt.abort-icon ( -- , just clear it out ) rt.icon-open? theIcon @ FreeDiskObject() theIcon OFF thestrings @ FREEBLOCK ; : $rt.get-icon ( adr-forth-string -- ) \ NOTE: do NOT include the '.info' suffix in the pathname \ does not work for DRAWER icons under WB (see ju:set-icon) \ this does however work with JazzBench theIcon @ IF " ERROR: 'theIcon' currently holds another icon." con.write.itl con.cr rt.abort THEN COUNT >DOS DOS0 GetDiskObject() -DUP 0= IF " ERROR: Can't Get the ICON file!" con.write.itl con.cr rt.abort THEN theIcon ! MEMF_PUBLIC 1024 ALLOCBLOCK -DUP 0= IF " ERROR: No memory for ICON strings!" con.write.itl con.cr rt.abort ELSE thestrings ! THEN ; : $rt.save-icon ( adr-forth-string -- ) \ AGAIN...do not append the '.info' rt.icon-open? COUNT >DOS DOS0 theIcon @ PutDiskObject() 0= IF " ERROR while saving DiskObject!" con.write.itl con.cr rt.abort THEN theIcon @ FreeDiskObject() theIcon OFF thestrings @ FREEBLOCK ; \ *** modified words from JU:AUTO_REQUEST *** \ want to change the dimensions and position of the requester : 0rt.auto.request ( 0body 0posi 0nega -- flag ) AR.INIT ACTIVE-WINDOW BODYTEXT POSITEXT NEGATEXT 0 0 320 60 ( these are changed ) CALL>ABS INTUITION_LIB AutoRequest ; : $rt.auto.request ( $body $posi $nega -- flag ) AR-NEGA-CHARS AR.GET.TEXT AR-POSI-CHARS AR.GET.TEXT AR-BODY-CHARS AR.GET.TEXT AR-BODY-CHARS AR-POSI-CHARS AR-NEGA-CHARS 0rt.auto.request ; \ *** support *** : rt.greeting ( -- ) " Replace the DefaultTool of Project Icons." con.write.itl con.cr " (c) Copyright by Richard Mazzarisi 1989, 1990" con.write.c3 con.cr " All rights reserved." con.write.c3 con.cr " Written in JForth Professional 2.0." con.write.c3 con.cr con.cr ; : prt.instr ( -- ) " Instructions:" con.write con.cr " 1 - Click on the icon for this program." con.write con.cr " 2 - Shift click on the Project icons to have their" con.write con.cr " DefaultTool changed and the icon for the Tool to" con.write con.cr " be set as the DefaultTool. Order is not important." con.write con.cr " 3 - OR shift click only on Project icons;" con.write con.cr " a file requester will appear allowing the" con.write con.cr " DefaultTool to be selected." con.write con.cr con.cr " (NOTE: The author assumes no responsibility for any" con.write con.cr " damages resulting from the use of this program.)" con.write con.cr ; : check.WB ( -- ) \ check if running under WorkBench? WBMESSAGE @ NOT IF " Must be run under the WorkBench!" con.write.itl con.cr con.cr prt.instr rt.abort THEN ; : check.num.args ( -- n t | f ) \ We need at least three args to make any sense. \ returns number of project arguments and true; or false if not enough WBMESSAGE @ >REL ..@ sm_NumArgs DUP 2 < IF \ not enough args; tell'em how " Too few arguments!" con.write.itl con.cr con.cr prt.instr DROP FALSE ELSE 1- ( 1st arg is ReplaceTool ) TRUE THEN ; : alloc.fib ( -- fib-addr ) \ allocate memory for the File Info Block MEMF_CLEAR SizeOf() FileInfoBlock ALLOCBLOCK DUP NULL = IF " ERROR: Could not allocate FileInfoBlock!" con.write.itl THEN ; : dealloc.fib ( fib-addr -- ) \ deallocate memory for the File Info Block DUP IF FREEBLOCK THEN ; : get.parentdir { lock | fib pdirflg dirflg ok --> dirflg ok } \ return in dirflg t if parent is a directory, f if it is disk (root) and t/f \ obviously dirflg is useless if all is not OK TRUE -> ok TRUE -> dirflg alloc.fib DUP -> fib IF \ go upward recursively lock ParentDir() -DUP IF DUP fib Examine() DROP RECURSE SWAP -> pdirflg IF fib .. fib_FileName 0COUNT PAD build.name pdirflg IF " /" COUNT PAD build.name ELSE " :" COUNT PAD build.name THEN ELSE FALSE -> ok THEN ELSE \ stop! reached the root dir, i.e. 'disk:' FALSE -> dirflg THEN fib dealloc.fib ELSE FALSE -> ok THEN ; : remove.final.slash ( stradd -- ) \ get rid of final slash on the name if there (put on drawer names by WB) DUP C@ OVER + C@ ASCII / = IF DUP C@ 1- SWAP C! ELSE DROP THEN ; : ?dev_name ( stradd -- ) \ return true if name ends in a colon DUP C@ SWAP + C@ ASCII : = ; : get.full-path { wb-arg | fib pdirflg ok --> ok } \ full path of file in wb-arg is written into PAD PAD init.name TRUE -> ok alloc.fib DUP -> fib IF \ get the directory path wb-arg ..@ wa_Lock fib Examine() DROP wb-arg ..@ wa_Lock get.parentdir SWAP -> pdirflg IF \ get directory name fib .. fib_FileName 0COUNT PAD build.name pdirflg IF " /" COUNT PAD build.name ELSE " :" COUNT PAD build.name THEN \ get name wb-arg ..@ wa_Name >REL 0COUNT PAD build.name ELSE FALSE -> ok THEN fib dealloc.fib PAD remove.final.slash PAD ?dev_name IF \ possibly a disk; try... " Disk" COUNT PAD build.name THEN ELSE FALSE -> ok THEN ; : check.if.tool { wb-arg -- t/f } \ check if file in wb-arg is a tool \ this will abort if fed a drawer under WB; OK however under JazzBench \ get file's path name wb-arg get.full-path IF PAD $rt.get-icon theIcon @ ..@ do_Type WBTOOL = rt.abort-icon ELSE " ERROR: Could not get path for:" con.write.itl wreq @ wb-arg ..@ wa_Name >REL ConPutStr() rt.abort THEN ; : find.tool ( wb-arg #args -- ) \ sets toolarg to # of the first(!) Tool found; 0 if none found 0 toolarg ! \ go thru icons to find the Tool 1+ 1 DO DUP SizeOf() WBArg I * + check.if.tool IF I toolarg ! LEAVE THEN LOOP DROP ; : verify.tool-path ( -- t/f ) \ verify with user that path is OK " DefaultTool path will be: " con.write con.cr " " con.write pathstr con.write con.cr con.cr " Is the DefaultTool path OK to use?" " OK, do it!" " No, Cancel" $rt.auto.request IF " Click closebox to abort." con.write con.cr con.cr TRUE ELSE " Cancelled!" con.write.itl con.cr FALSE THEN ; : do.requester ( -- frstruct | f ) \ uses arp.library file requester to get tool path \ returns relative pointer to filerequester structure or false ArpAllocFreq() DUP IF 0" Select Tool to be used:" >ABS OVER ..! fr_Hail \ set default dir (make sure CMOVE's count is OK) 0" SYS:" OVER ..@ fr_Dir >REL 5 CMOVE DUP FileRequest() -DUP 0= IF \ return is 0 => Cancel hit " Cancelled!" con.write.itl con.cr DROP FALSE ELSE C@ 0= IF \ string empty => return key hit with \ no file selected " ERROR: No tool selected!" con.write.itl con.cr con.cr prt.instr DROP FALSE THEN THEN ELSE " ERROR: Could not get file requester!" con.write.itl con.cr THEN ; : setup.pathstr ( frstruct -- ) \ writes path and tool name from arp file requester into pathstr pathstr init.name \ build directory name if one given DUP ..@ fr_Dir >REL DUP C@ 0> IF \ path is not empty 0COUNT 2DUP pathstr build.name \ make sure this not a device name 1- + C@ DUP ASCII : = NOT SWAP ASCII / = NOT AND IF \ ok to put in a '/' " /" COUNT pathstr build.name THEN ELSE DROP THEN \ now add file name ..@ fr_File >REL 0COUNT pathstr build.name ; : request.tool-path ( -- t/f ) \ get Tool via the arp file requester, set up string and check with user \ (probably should check if in fact a Tool was selected, but we have no icon) open.arp-lib IF do.requester -DUP IF setup.pathstr verify.tool-path ELSE FALSE THEN ELSE " ERROR: Could not open arp.library!" con.write.itl con.cr con.cr prt.instr FALSE THEN ; : find.tool-path { wb-arg -- t/f } \ writes full path of tool into pathstr wb-arg toolarg @ SizeOf() WBArg * + get.full-path IF PAD pathstr $MOVE verify.tool-path ELSE " ERROR: Could not get path for the tool: " con.write.itl wreq @ wb-arg toolarg @ SizeOf() WBArg * + ..@ wa_Name >REL ConPutStr() con.cr FALSE THEN ; : get.tool-path ( wbarg -- t/f ) toolarg @ IF find.tool-path ELSE \ no tool specified, use requester DROP request.tool-path THEN ; : replace.it ( -- ) \ replaces the DefaultTool only if the icon represents a Project PAD $rt.get-icon theIcon @ ..@ do_Type WBPROJECT = IF [ clone-it @ ] .IF pathstr $SET-DEFAULT-TOOL PAD $rt.save-icon .ELSE \ don't really do it if we are testing things in the interpreter rt.abort-icon .THEN ELSE " is not a project! Default tool not replaced" con.write.itl con.cr con.cr rt.abort-icon THEN ; : make.one-rplcmt { wb-arg -- } \ get file's path name wb-arg get.full-path IF " " con.write PAD con.write con.cr replace.it ELSE " ERROR: Could not get path for project:" con.write.itl con.cr " " con.write wreq @ wb-arg ..@ wa_Name >REL ConPutStr() con.cr THEN ; : do.replacements ( wb-arg #args -- ) \ go thru icons of the projects to be changed \ skipping the tool " Replacing the DefaultTool for:" con.write con.cr 1+ 1 DO I toolarg @ = NOT IF DUP SizeOf() WBArg I * + make.one-rplcmt THEN \ check for stop action ?CLOSEBOX IF LEAVE THEN LOOP DROP con.cr " Done. " con.write.itl ; \ *** main *** : replacetool ( -- ) open.rt-things cursor.off rt.greeting check.WB check.num.args IF \ get pointer to args WBMESSAGE @ >REL ..@ sm_ArgList >REL SWAP 2DUP find.tool OVER get.tool-path IF do.replacements ELSE 2DROP THEN THEN close.rt-things ; : rt replacetool ; clone-it @ .IF initclone clone replacetool save-image replacetool ReplaceTool -icon .THEN CR CR ." Type 'rt' to run." CR CR