home *** CD-ROM | disk | FTP | other *** search
/ Club Amiga de Montreal - CAM / CAM_CD_1.iso / files / 402.lha / IconTools / source / ReplaceTool.f < prev    next >
Text File  |  1990-07-27  |  16KB  |  726 lines
  1. \ ReplaceTool.f    2.02
  2. \ Program to change the default tool of a number project icons simultaneously,
  3. \   using the Workbench and Intuition.
  4. \ Written in JForth Professional 2.0
  5. \
  6. \ (c) Copyright 1989, 1990 by Richard Mazzarisi
  7. \    All rights reserved.
  8. \
  9. \ address:
  10. \    891 Post St. #207
  11. \    San Francisco, CA
  12. \    94109
  13. \
  14. \  email:
  15. \    rich@californium.cchem.berkeley.edu
  16. \    rmazz@hydrogen.cchem.berkeley.edu
  17. \    nmr@garnet.berkeley.edu
  18. \
  19. \
  20. \ 5/20/90
  21. \
  22. \ v. 1.00 9/2/89
  23. \ v. 1.01 10/9/89  order of clicking icons no longer matters
  24. \ v. 2.00 2/1/90   added arp file requester if no tool clicked
  25. \ v. 2.01 3/22/90  fixed problem with final slash in drawer names from WB; if
  26. \            a drawer was selected prog does error exit
  27. \            (not a problem with JazzBench)
  28. \      3/24/90  fixed problem similar to '/' with ':' on device icons
  29. \      3/25/90  moved arp library openning away from startup - it is not
  30. \            needed unless no tool icon is selected; no need to
  31. \            abort if user clicks on a tool along with projects
  32. \ v. 2.02 5/15/90  fixed the tendency to crash if the arp file req returns
  33. \            a null string for the drawer
  34. \      5/20/90  fixed the ability to find the font size and use this info
  35. \            in opening the window
  36. \
  37. \ Instructions:
  38. \ 1 - Click on the icon for this program.
  39. \ 2 - Shift click on the Project icons to have their
  40. \     DefaultTool changed and the icon for the Tool to be
  41. \     set as the DefaultTool.
  42. \ 3 - OR shift click only on Project icons; a file requester will
  43. \     appear allowing the DefaultTool to be selected.
  44. \
  45. \ (NOTE: The author assumes no responsibility for any damages
  46. \ resulting from the use of this program.)
  47.  
  48. INCLUDE? CLONE CL:TOPFILE
  49. INCLUDE? LIBRARIES_DOS_H JI:LIBRARIES/DOS.J
  50. INCLUDE? LIBRARIES_DOSEXTENS_H JI:LIBRARIES/DOSEXTENS.J
  51. INCLUDE? EXEC_MEMORY_H JI:EXEC/MEMORY.J
  52. INCLUDE? TASK-AMIGA_GRAPH JU:AMIGA_GRAPH
  53. INCLUDE? TASK-AMIGA_EVENTS JU:AMIGA_EVENTS
  54. INCLUDE? TASK-CONSOLESUPPORT JU:CONSOLESUPPORT
  55. INCLUDE? TASK-ANSISUPPORT JU:ANSISUPPORT
  56. INCLUDE? TASK-DOS-SUPPORT JU:DOS-SUPPORT
  57. INCLUDE? TASK-AUTO_REQUEST JU:AUTO_REQUEST
  58. INCLUDE? TASK-SET-ICON JU:SET-ICON
  59. INCLUDE? TASK-LOCALS JU:LOCALS
  60. INCLUDE? LIBRARIES_ARPBASE_H JARP:ARPBASE.J
  61. INCLUDE? TASK-ARP_SUPPORT JARP:ARP_SUPPORT
  62.  
  63.  
  64. .NEED clone-it
  65.  
  66. \ *** clone controller ***
  67.  
  68. VARIABLE clone-it
  69. clone-it OFF
  70.  
  71. .THEN
  72.  
  73.  
  74. ANEW task-replacetool
  75.  
  76. DECIMAL
  77.  
  78.  
  79. \ *** constants ***
  80.  
  81. \ # bytes to be allocated for the path string; biggest string which can
  82. \  be returned from arp filerequester
  83. LONG_DSIZE LONG_FSIZE + 1+ CONSTANT pathsize
  84.  
  85. \ *** variables ***
  86.  
  87. VARIABLE toolarg        \ holds the position of the Tool arg
  88.  
  89. \ *** console stuff ***
  90.  
  91. \ variables to hold the request and reply ports
  92. VARIABLE wreq
  93. VARIABLE rreq
  94. VARIABLE wreply
  95. VARIABLE rreply
  96.  
  97.  
  98. : con.cr        ( -- )
  99.     wreq @ $ 0A ConPutChar()
  100. ;
  101.  
  102.  
  103. : con.write        ( straddr -- )
  104.     wreq @    SWAP COUNT ConWrite()
  105. ;
  106.  
  107.  
  108. : con.write.c3        ( straddr -- )
  109. \ write string in color 3
  110.     1 33 2 CRender3  wreq @  >ANSIDEVICE
  111.     con.write
  112.     0 1 CRender3  wreq @  >ANSIDEVICE
  113. ;
  114.  
  115.  
  116. : con.write.itl     ( straddr -- )
  117. \ write string in bold italics
  118.     3 1 2 CRender3    wreq @    >ANSIDEVICE
  119.     con.write
  120.     0 1 CRender3  wreq @  >ANSIDEVICE
  121. ;
  122.  
  123.  
  124. : clear.line        ( -- )
  125. \ clear current line
  126.     0 CDeleteLine wreq @ >ANSIDEVICE
  127. ;
  128.  
  129.  
  130. : cursor.off        ( -- )
  131. \ get rid of cursor
  132.     0 CCursOff wreq @ >ANSIDEVICE
  133. ;
  134.  
  135.  
  136. \ *** main window stuff ***
  137.  
  138. CREATE scr-buff Sizeof() Screen ALLOT
  139. NewWindow rt-window
  140.  
  141. : getWBscreendata    ( -- )
  142.     scr-buff Sizeof() Screen WBENCHSCREEN NULL
  143.     CALL>ABS INTUITION_LIB GetScreenData  NULL = IF
  144.         ABORT" Could not get Workbench screen data."
  145.     THEN
  146. ;
  147.  
  148.  
  149. : set.vert-params ( topedge #lines -- topedge' height )
  150. \ calc window height, adjust topedge if necessary
  151.     scr-buff ..@ sc_Font            \ get font
  152.     >REL ..@ ta_YSize            \ font height
  153.     \ estimate height from #lines, title bar height and lower border
  154.     *  scr-buff ..@ sc_BarHeight +    12 +
  155.     \ check if too high
  156.     2DUP +    scr-buff ..@ sc_Height > IF
  157.         \ try adjusting topedge
  158.         SWAP DROP   \ lose old topedge
  159.         scr-buff ..@ sc_Height OVER -  DUP 0< IF
  160.             \ not going to work; set to 0 & screen height
  161.             2DROP
  162.             0 scr-buff ..@ sc_Height
  163.         ELSE
  164.             SWAP
  165.         THEN
  166.     THEN
  167. ;
  168.  
  169.  
  170. : set.horiz-params ( leftedge #chars -- leftedge' width )
  171. \ calc window width, adjust leftedge if necessary
  172.     scr-buff .. sc_RastPort ..@ rp_TxWidth        \ get font width
  173.     \ estimate width from #chars, and borders
  174.     *  24 +
  175.     \ check if too wide
  176.     2DUP +    scr-buff ..@ sc_Width > IF
  177.         \ try adjusting leftedge
  178.         SWAP DROP   \ lose old leftedge
  179.         scr-buff ..@ sc_Width OVER -  DUP 0< IF
  180.             \ not going to work; set to 0 & screen width
  181.             2DROP
  182.             0 scr-buff ..@ sc_Width
  183.         ELSE
  184.             SWAP
  185.         THEN
  186.     THEN
  187. ;
  188.  
  189.  
  190. : open.rt-window    ( -- window/null )
  191.     getWBscreendata
  192.     rt-window NEWWINDOW.SETUP
  193.     20 20 set.vert-params
  194.     rt-window ..! nw_Height
  195.     rt-window ..! nw_TopEdge
  196.     20 55 set.horiz-params
  197.     rt-window ..! nw_Width
  198.     rt-window ..! nw_LeftEdge
  199.     0" ReplaceTool  2.02" >ABS rt-window ..! nw_Title
  200.     CLOSEWINDOW rt-window ..! nw_IDCMPFlags
  201.     WINDOWCLOSE WINDOWDRAG | WINDOWDEPTH | WINDOWSIZING |
  202.         rt-window ..! nw_Flags
  203.     rt-window GR.OPENCURW
  204. ;
  205.  
  206.  
  207. : wait.close        ( -- )
  208.     BEGIN
  209.         GR-CURWINDOW @ EV.WAIT
  210.         GR-CURWINDOW @ EV.GETCLASS
  211.         CLOSEWINDOW =
  212.     UNTIL
  213. ;
  214.  
  215.  
  216. \ *** string stuff ***
  217.  
  218. CREATE pathstr    pathsize ALLOT         \ holds path to be put into Icons
  219.  
  220. : init.name        ( dest -- )
  221.     0 SWAP !
  222. ;
  223.  
  224.  
  225. : build.name        ( addr count dest -- )
  226. \ build string in buffer at dest, must init to null with init.name before
  227. \ using this word for the first time in building a new path name
  228.     \ check for a non null in first place
  229.     DUP @ 0= IF
  230.         \ it was just initialized so just copy
  231.         >$
  232.     ELSE
  233.         $APPEND
  234.     THEN
  235. ;
  236.  
  237.  
  238. \ *** resource management ***
  239.  
  240. : close.rt-things    ( -- )
  241.     con.cr " Click CloseBox to exit." con.write
  242.     wait.close
  243.     wreq @ 0= NOT IF
  244.         wreply @ wreq @ rreply @ rreq @ ReleaseConsole()
  245.         wreq OFF
  246.     THEN
  247.     GR.CLOSECURW
  248.     GR.TERM     \ close graphics
  249.     -ARP        \ and arp.library if it was used
  250. ;
  251.  
  252.  
  253. : rt.abort        ( -- )
  254.     con.cr
  255.     close.rt-things
  256.     ABORT
  257. ;
  258.  
  259.  
  260. : open.rt-things    ( -- t/f )
  261. \ The error messages are for debugging under the interpreter; they won't
  262. \ be able to be seen under the workbench.
  263.     GR.INIT     \ open graphics
  264.     wreq OFF
  265.     GR-CURWINDOW OFF
  266.     \ open window
  267.     open.rt-window    NULL = IF
  268.         -ARP
  269.         ABORT" Could not open a window!"
  270.     THEN
  271.     \ make it a console
  272.     GR-CURWINDOW @ GetConsole() NULL = IF
  273.         close.rt-things
  274.         ABORT" Could not create a console device!"
  275.     ELSE
  276.         rreq ! rreply !  wreq ! wreply !
  277.         cursor.off
  278.     THEN
  279. ;
  280.  
  281.  
  282. \ *** modified words from JU:SET-ICON ***
  283. \ these must not call ?ABORT" but must use rt.abort to clean up
  284. \ (probably don't need most of the error messages but leave them for
  285. \ debugging from the interpreter)
  286.  
  287. : rt.icon-open?     ( -- , just checks for 0 )
  288.     theIcon @ 0= IF
  289.         " ERROR: No Icon selected ... use GET-ICON" con.write.itl con.cr
  290.         rt.abort
  291.     THEN
  292. ;
  293.  
  294.  
  295. : rt.abort-icon     ( -- , just clear it out )
  296.     rt.icon-open? theIcon @  FreeDiskObject()
  297.     theIcon OFF  thestrings @ FREEBLOCK
  298. ;
  299.  
  300.  
  301. : $rt.get-icon        ( adr-forth-string -- )
  302. \ NOTE: do NOT include the '.info' suffix in the pathname
  303. \ does not work for DRAWER icons under WB (see ju:set-icon)
  304. \ this does however work with JazzBench
  305.     theIcon @ IF
  306.         " ERROR: 'theIcon' currently holds another icon."
  307.         con.write.itl con.cr
  308.         rt.abort
  309.     THEN
  310.     COUNT >DOS DOS0   GetDiskObject() -DUP 0= IF
  311.         " ERROR: Can't Get the ICON file!" con.write.itl con.cr
  312.         rt.abort
  313.     THEN
  314.     theIcon !  MEMF_PUBLIC 1024 ALLOCBLOCK -DUP 0= IF
  315.         " ERROR: No memory for ICON strings!" con.write.itl con.cr
  316.         rt.abort
  317.     ELSE
  318.         thestrings !
  319.     THEN
  320. ;
  321.  
  322.  
  323. : $rt.save-icon     ( adr-forth-string -- )
  324.     \ AGAIN...do not append the '.info'
  325.     rt.icon-open?  COUNT >DOS DOS0    theIcon @  PutDiskObject() 0= IF
  326.         " ERROR while saving DiskObject!" con.write.itl con.cr
  327.         rt.abort
  328.     THEN
  329.     theIcon @  FreeDiskObject()  theIcon OFF  thestrings @ FREEBLOCK
  330. ;
  331.  
  332.  
  333. \ *** modified words from JU:AUTO_REQUEST ***
  334. \ want to change the dimensions and position of the requester
  335.  
  336. : 0rt.auto.request    ( 0body 0posi 0nega -- flag )
  337.     AR.INIT
  338.     ACTIVE-WINDOW
  339.     BODYTEXT
  340.     POSITEXT
  341.     NEGATEXT
  342.     0 0 320 60          ( these are changed )
  343.     CALL>ABS INTUITION_LIB AutoRequest
  344. ;
  345.  
  346.  
  347. : $rt.auto.request    ( $body $posi $nega -- flag )
  348.     AR-NEGA-CHARS AR.GET.TEXT
  349.     AR-POSI-CHARS AR.GET.TEXT
  350.     AR-BODY-CHARS AR.GET.TEXT
  351.     AR-BODY-CHARS AR-POSI-CHARS AR-NEGA-CHARS
  352.     0rt.auto.request
  353. ;
  354.  
  355.  
  356.  
  357. \ *** support ***
  358.  
  359. : rt.greeting        ( -- )
  360.     " Replace the DefaultTool of Project Icons." con.write.itl con.cr
  361.     " (c) Copyright by Richard Mazzarisi 1989, 1990" con.write.c3 con.cr
  362.     "          All rights reserved." con.write.c3 con.cr
  363.     "      Written in JForth Professional 2.0." con.write.c3 con.cr con.cr
  364. ;
  365.  
  366.  
  367. : prt.instr        ( -- )
  368.     " Instructions:"  con.write con.cr
  369.     " 1 - Click on the icon for this program."  con.write con.cr
  370.     " 2 - Shift click on the Project icons to have their"  con.write con.cr
  371.     "     DefaultTool changed and the icon for the Tool to"  con.write con.cr
  372.     "     be set as the DefaultTool.  Order is not important."  con.write con.cr
  373.     " 3 - OR shift click only on Project icons;"  con.write con.cr
  374.     "     a file requester will appear allowing the"  con.write con.cr
  375.     "     DefaultTool to be selected."  con.write con.cr con.cr
  376.     " (NOTE: The author assumes no responsibility for any"
  377.     con.write con.cr
  378.     " damages resulting from the use of this program.)" con.write con.cr
  379. ;
  380.  
  381.  
  382. : check.WB        ( -- )
  383.     \ check if running under WorkBench?
  384.     WBMESSAGE @ NOT IF
  385.         " Must be run under the WorkBench!" con.write.itl con.cr con.cr
  386.         prt.instr  rt.abort
  387.     THEN
  388. ;
  389.  
  390.  
  391. : check.num.args    ( -- n t | f )
  392. \ We need at least three args to make any sense.
  393. \ returns number of project arguments and true; or false if not enough
  394.     WBMESSAGE @ >REL ..@ sm_NumArgs  DUP 2 <  IF
  395.         \ not enough args; tell'em how
  396.         " Too few arguments!" con.write.itl con.cr con.cr
  397.         prt.instr
  398.         DROP FALSE
  399.     ELSE
  400.         1-  ( 1st arg is ReplaceTool )
  401.         TRUE
  402.     THEN
  403. ;
  404.  
  405.  
  406. : alloc.fib        ( -- fib-addr )
  407.     \ allocate memory for the File Info Block
  408.     MEMF_CLEAR  SizeOf() FileInfoBlock  ALLOCBLOCK
  409.     DUP NULL = IF
  410.         " ERROR: Could not allocate FileInfoBlock!" con.write.itl
  411.     THEN
  412. ;
  413.  
  414.  
  415. : dealloc.fib        ( fib-addr -- )
  416.     \ deallocate memory for the File Info Block
  417.     DUP IF
  418.         FREEBLOCK
  419.     THEN
  420. ;
  421.  
  422.  
  423. : get.parentdir     { lock | fib pdirflg dirflg ok --> dirflg ok }
  424. \ return in dirflg t if parent is a directory, f if it is disk (root) and t/f
  425. \ obviously dirflg is useless if all is not OK
  426.     TRUE -> ok  TRUE -> dirflg
  427.     alloc.fib  DUP -> fib  IF
  428.         \ go upward recursively
  429.         lock ParentDir()  -DUP IF
  430.             DUP fib Examine()  DROP
  431.             RECURSE  SWAP -> pdirflg  IF
  432.                 fib .. fib_FileName  0COUNT  PAD build.name
  433.                 pdirflg IF
  434.                     " /" COUNT  PAD build.name
  435.                 ELSE
  436.                     " :" COUNT  PAD build.name
  437.                 THEN
  438.             ELSE
  439.                 FALSE -> ok
  440.             THEN
  441.         ELSE
  442.             \ stop! reached the root dir, i.e. 'disk:'
  443.             FALSE -> dirflg
  444.         THEN
  445.         fib dealloc.fib
  446.     ELSE
  447.         FALSE -> ok
  448.     THEN
  449. ;
  450.  
  451.  
  452. : remove.final.slash          ( stradd -- )
  453. \ get rid of final slash on the name if there (put on drawer names by WB)
  454.     DUP C@
  455.     OVER + C@  ASCII / = IF
  456.         DUP C@ 1-  SWAP C!
  457.     ELSE
  458.         DROP
  459.     THEN
  460. ;
  461.  
  462.  
  463. : ?dev_name         ( stradd -- )
  464. \ return true if name ends in a colon
  465.     DUP C@
  466.     SWAP + C@  ASCII : =
  467. ;
  468.  
  469.  
  470. : get.full-path     { wb-arg | fib pdirflg ok --> ok }
  471. \ full path of file in wb-arg is written into PAD
  472.     PAD init.name
  473.     TRUE -> ok
  474.     alloc.fib  DUP -> fib  IF
  475.         \ get the directory path
  476.         wb-arg ..@ wa_Lock  fib  Examine()  DROP
  477.         wb-arg ..@ wa_Lock get.parentdir  SWAP -> pdirflg  IF
  478.             \ get directory name
  479.             fib .. fib_FileName  0COUNT  PAD build.name
  480.             pdirflg IF
  481.                 " /" COUNT  PAD build.name
  482.             ELSE
  483.                 " :" COUNT  PAD build.name
  484.             THEN
  485.             \ get name
  486.             wb-arg ..@ wa_Name >REL 0COUNT    PAD build.name
  487.         ELSE
  488.             FALSE -> ok
  489.         THEN
  490.         fib dealloc.fib
  491.         PAD remove.final.slash
  492.         PAD ?dev_name IF
  493.             \ possibly a disk; try...
  494.             " Disk" COUNT PAD build.name
  495.         THEN
  496.     ELSE
  497.         FALSE -> ok
  498.     THEN
  499. ;
  500.  
  501.  
  502. : check.if.tool     { wb-arg -- t/f }
  503. \ check if file in wb-arg is a tool
  504. \ this will abort if fed a drawer under WB; OK however under JazzBench
  505.     \ get file's path name
  506.     wb-arg get.full-path IF
  507.         PAD $rt.get-icon
  508.         theIcon @ ..@ do_Type  WBTOOL =
  509.         rt.abort-icon
  510.     ELSE
  511.         " ERROR: Could not get path for:" con.write.itl
  512.         wreq @ wb-arg ..@ wa_Name >REL ConPutStr()
  513.         rt.abort
  514.     THEN
  515. ;
  516.  
  517.  
  518. : find.tool        ( wb-arg #args -- )
  519. \ sets toolarg to # of the first(!) Tool found; 0 if none found
  520.     0 toolarg !
  521.     \ go thru icons to find the Tool
  522.     1+  1  DO
  523.         DUP  SizeOf() WBArg  I *  +
  524.         check.if.tool IF
  525.             I toolarg !  LEAVE
  526.         THEN
  527.     LOOP
  528.     DROP
  529. ;
  530.  
  531.  
  532. : verify.tool-path    ( -- t/f )
  533. \ verify with user that path is OK
  534.     " DefaultTool path will be: " con.write con.cr
  535.     "    " con.write
  536.     pathstr con.write con.cr con.cr
  537.     " Is the DefaultTool path OK to use?"
  538.     " OK, do it!" " No, Cancel" $rt.auto.request IF
  539.         " Click closebox to abort."  con.write
  540.         con.cr con.cr
  541.         TRUE
  542.     ELSE
  543.         " Cancelled!" con.write.itl con.cr
  544.         FALSE
  545.     THEN
  546. ;
  547.  
  548.  
  549. : do.requester        ( -- frstruct | f )
  550. \ uses arp.library file requester to get tool path
  551. \ returns relative pointer to filerequester structure or false
  552.     ArpAllocFreq() DUP IF
  553.         0" Select Tool to be used:" >ABS OVER ..! fr_Hail
  554.         \ set default dir (make sure CMOVE's count is OK)
  555.         0" SYS:"  OVER ..@ fr_Dir >REL  5 CMOVE
  556.         DUP FileRequest()  -DUP 0= IF
  557.             \ return is 0 => Cancel hit
  558.             " Cancelled!" con.write.itl con.cr
  559.             DROP FALSE
  560.         ELSE
  561.             C@ 0= IF
  562.                 \ string empty => return key hit with
  563.                 \ no file selected
  564.                 " ERROR: No tool selected!" con.write.itl
  565.                 con.cr con.cr
  566.                 prt.instr
  567.                 DROP FALSE
  568.             THEN
  569.         THEN
  570.     ELSE
  571.         " ERROR: Could not get file requester!" con.write.itl con.cr
  572.     THEN
  573. ;
  574.  
  575.  
  576. : setup.pathstr     ( frstruct -- )
  577. \ writes path and tool name from arp file requester into pathstr
  578.     pathstr init.name
  579.     \ build directory name if one given
  580.     DUP ..@ fr_Dir >REL  DUP C@ 0> IF
  581.         \ path is not empty
  582.         0COUNT    2DUP pathstr build.name
  583.         \ make sure this not a device name
  584.         1- + C@ DUP ASCII : = NOT  SWAP ASCII / = NOT  AND IF
  585.             \ ok to put in a '/'
  586.             " /" COUNT pathstr build.name
  587.         THEN
  588.     ELSE
  589.         DROP
  590.     THEN
  591.     \ now add file name
  592.     ..@ fr_File >REL 0COUNT pathstr build.name
  593. ;
  594.  
  595.  
  596. : request.tool-path    ( -- t/f )
  597. \ get Tool via the arp file requester, set up string and check with user
  598. \ (probably should check if in fact a Tool was selected, but we have no icon)
  599.     open.arp-lib IF
  600.         do.requester -DUP IF
  601.             setup.pathstr
  602.             verify.tool-path
  603.         ELSE
  604.             FALSE
  605.         THEN
  606.     ELSE
  607.         " ERROR: Could not open arp.library!" con.write.itl
  608.         con.cr con.cr
  609.         prt.instr
  610.         FALSE
  611.     THEN
  612. ;
  613.  
  614.  
  615. : find.tool-path    { wb-arg -- t/f }
  616. \ writes full path of tool into pathstr
  617.     wb-arg    toolarg @  SizeOf() WBArg *  +
  618.     get.full-path IF
  619.         PAD pathstr $MOVE
  620.         verify.tool-path
  621.     ELSE
  622.         " ERROR: Could not get path for the tool: " con.write.itl
  623.         wreq @    wb-arg toolarg @  SizeOf() WBArg *  + ..@ wa_Name >REL
  624.         ConPutStr() con.cr
  625.         FALSE
  626.     THEN
  627. ;
  628.  
  629.  
  630. : get.tool-path     ( wbarg -- t/f )
  631.     toolarg @ IF
  632.         find.tool-path
  633.     ELSE
  634.         \ no tool specified, use requester
  635.         DROP request.tool-path
  636.     THEN
  637. ;
  638.  
  639.  
  640. : replace.it        ( -- )
  641. \ replaces the DefaultTool only if the icon represents a Project
  642.     PAD $rt.get-icon
  643.     theIcon @ ..@ do_Type  WBPROJECT = IF
  644. [ clone-it @ ] .IF
  645.         pathstr $SET-DEFAULT-TOOL
  646.         PAD $rt.save-icon
  647. .ELSE
  648. \ don't really do it if we are testing things in the interpreter
  649.         rt.abort-icon
  650. .THEN
  651.     ELSE
  652.         "    is not a project! Default tool not replaced"
  653.         con.write.itl con.cr con.cr
  654.         rt.abort-icon
  655.     THEN
  656. ;
  657.  
  658.  
  659. : make.one-rplcmt     { wb-arg -- }
  660.     \ get file's path name
  661.     wb-arg get.full-path IF
  662.         "   " con.write
  663.         PAD con.write con.cr
  664.         replace.it
  665.     ELSE
  666.         " ERROR: Could not get path for project:" con.write.itl con.cr
  667.         "   " con.write
  668.         wreq @ wb-arg ..@ wa_Name >REL ConPutStr() con.cr
  669.     THEN
  670. ;
  671.  
  672.  
  673. : do.replacements    ( wb-arg #args -- )
  674.     \ go thru icons of the projects to be changed
  675.     \ skipping the tool
  676.     " Replacing the DefaultTool for:" con.write con.cr
  677.     1+  1  DO
  678.         I toolarg @ = NOT IF
  679.             DUP  SizeOf() WBArg  I *  +
  680.             make.one-rplcmt
  681.         THEN
  682.         \ check for stop action
  683.         ?CLOSEBOX IF LEAVE THEN
  684.     LOOP
  685.     DROP
  686.     con.cr " Done.  " con.write.itl
  687. ;
  688.  
  689.  
  690. \ *** main ***
  691.  
  692. : replacetool        ( -- )
  693.     open.rt-things
  694.     cursor.off
  695.     rt.greeting
  696.     check.WB
  697.     check.num.args IF
  698.         \ get pointer to args
  699.         WBMESSAGE @ >REL ..@ sm_ArgList >REL  SWAP
  700.         2DUP find.tool
  701.         OVER get.tool-path
  702.         IF
  703.             do.replacements
  704.         ELSE
  705.             2DROP
  706.         THEN
  707.     THEN
  708.     close.rt-things
  709. ;
  710.  
  711.  
  712. : rt
  713.     replacetool
  714. ;
  715.  
  716.  
  717. clone-it @ .IF
  718.  
  719. initclone
  720. clone replacetool
  721. save-image replacetool ReplaceTool -icon
  722.  
  723. .THEN
  724.  
  725. CR CR ." Type 'rt' to run." CR CR
  726.