home *** CD-ROM | disk | FTP | other *** search
/ System Booster / System Booster.iso / Desktop Improver / IconTools / source / ReplaceTool.f < prev    next >
Encoding:
FORTH Source  |  1996-09-27  |  11.1 KB  |  469 lines
  1. \ $VER: ReplaceTool.f 2.04 (19 Jan 1992 23:34)
  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, 1992 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. \ v. 1.00 9/2/89
  21. \ v. 1.01 10/9/89  order of clicking icons no longer matters
  22. \ v. 2.00 2/1/90   added arp file requester if no tool clicked
  23. \ v. 2.01 3/22/90  fixed problem with final slash in drawer names from WB; if
  24. \            a drawer was selected prog does error exit
  25. \            (not a problem with JazzBench)
  26. \      3/24/90  fixed problem similar to '/' with ':' on device icons
  27. \      3/25/90  moved arp library openning away from startup - it is not
  28. \            needed unless no tool icon is selected; no need to
  29. \            abort if user clicks on a tool along with projects
  30. \ v. 2.02 5/15/90  fixed the tendency to crash if the arp file req returns
  31. \            a null string for the drawer
  32. \      5/20/90  fixed the ability to find the font size and use this info
  33. \            in opening the window
  34. \ v. 2.03 1/1/92   fixed once and for all the finding of the font size
  35. \      1/7/92   put all icontools common stuff into icontools.f
  36. \      1/7/92   made the situatin where one clicks only on a tool a little
  37. \            more helpful in explaining why nothing happens
  38. \      1/13/92  moved the resource management routines to IconTools.f
  39. \           put in the use of 2.04's file requester so that arp is
  40. \            not needed unless WB 1.3 is being used
  41. \ v. 2.04 1/19/92  moved window down so that requester will not obscure the
  42. \            name of the tool to be used if a large screen
  43. \            font is used
  44. \                  recompiled with new IconTools.f (cf)
  45. \
  46. \
  47. \ Instructions:
  48. \ 1 - Click on the icon for this program.
  49. \ 2 - Shift click on the Project icons to have their
  50. \     DefaultTool changed AND the icon for the Tool to be
  51. \     set as the DefaultTool.
  52. \ 3 - <<OR>> shift click only on one or more Project icons;
  53. \     a file requester will appear allowing the DefaultTool to be selected.
  54. \
  55. \ (NOTE: The author assumes no responsibility for any damages
  56. \ resulting from the use of this program.)
  57.  
  58.  
  59. INCLUDE? TASK-ICONTOOLS ICONTOOLS.F
  60. \ for arp file rquester
  61. INCLUDE? LIBRARIES_ARPBASE_H JARP:ARPBASE.J
  62. INCLUDE? TASK-ARP_SUPPORT JARP:ARP_SUPPORT
  63. \ for asl file rquester
  64. INCLUDE? LIBRARIES_ASL_H JI:LIBRARIES/ASL.J
  65. INCLUDE? TASK-ASL_SUPPORT JU:ASL_SUPPORT
  66.  
  67.  
  68. ANEW task-replacetool
  69.  
  70. DECIMAL
  71.  
  72.  
  73. \ *** constants ***
  74.  
  75. \ # bytes to be allocated for the path string; biggest string which can
  76. \  be returned from arp filerequester
  77. LONG_DSIZE LONG_FSIZE + 1+ CONSTANT pathsize
  78.  
  79.  
  80. \ *** variables ***
  81.  
  82. VARIABLE toolarg        \ holds the position of the Tool arg
  83. CREATE pathstr    pathsize ALLOT         \ holds path to be put into Icons
  84.  
  85.  
  86. \ *** main window stuff ***
  87.  
  88. : open.rt-window    ( -- window/null )
  89.     getWBscreendata
  90.     it-newwindow NEWWINDOW.SETUP
  91.     45 21 set.vert-params
  92.     it-newwindow ..! nw_Height
  93.     it-newwindow ..! nw_TopEdge
  94.     20 56 set.horiz-params
  95.     it-newwindow ..! nw_Width
  96.     it-newwindow ..! nw_LeftEdge
  97.     0" ReplaceTool  2.04" >ABS it-newwindow ..! nw_Title
  98.     CLOSEWINDOW it-newwindow ..! nw_IDCMPFlags
  99.     WINDOWCLOSE WINDOWDRAG | WINDOWDEPTH | WINDOWSIZING | ACTIVATE |
  100.         it-newwindow ..! nw_Flags
  101.     it-newwindow GR.OPENCURW
  102. ;
  103.  
  104.  
  105. \ *** file requester stuff ***
  106.  
  107. VARIABLE rt-filereq
  108. VARIABLE ASL-flg    \ flag for which file requester we are using
  109. 4 CONSTANT nalloctags
  110. CREATE alloctaglist nalloctags 2* CELLS ALLOT
  111.  
  112.  
  113. : fill.tags    ( tags1 ... tagN taglist ntags -- )
  114.     2* CELLS OVER +  SWAP  DO
  115.         I !
  116.     1 CELLS +LOOP
  117. ;
  118.  
  119.  
  120. : hail.txt        ( -- 0string )
  121.     0" Select Tool to be used:"
  122. ;
  123.  
  124.  
  125. : dir.txt        ( -- 0string )
  126.     0" SYS:"
  127. ;
  128.  
  129.  
  130. : fr-dir        ( -- 0string )
  131.     rt-filereq @
  132.     ASL-flg @ IF
  133.         ..@ rf_Dir
  134.     ELSE
  135.         ..@ fr_Dir
  136.     THEN
  137.     >REL
  138. ;
  139.  
  140.  
  141. : fr-file        ( -- 0string )
  142.     rt-filereq @
  143.     ASL-flg @ IF
  144.         ..@ rf_File
  145.     ELSE
  146.         ..@ fr_File
  147.     THEN
  148.     >REL
  149. ;
  150.  
  151.  
  152. : open.fr-lib        ( -- t/f)
  153.     open.asl-lib  -DUP IF
  154.         ASL-flg ON
  155.     ELSE
  156.         ASL-flg OFF
  157.                 open.arp-lib  DUP 0= IF
  158.                         " ERROR: Could not open asl or arp library!"
  159.                         con.write.itl con.cr con.cr
  160.                         prt.it-instr
  161.                 THEN
  162.     THEN
  163. ;
  164.  
  165.  
  166. : alloc.fr        ( -- t/f )
  167.     ASL-flg @ IF
  168.                 0 TAG_END
  169.                 0" ~(#?.info)" >ABS ASL_Pattern
  170.                 dir.txt >ABS ASL_Dir
  171.                 hail.txt >ABS ASL_Hail
  172.                 alloctaglist nalloctags fill.tags
  173.                 ASL_FileRequest alloctaglist AllocAslRequest()
  174.                 DUP rt-filereq !
  175.     ELSE
  176.                 ArpAllocFreq()  DUP rt-filereq !
  177.                 DUP 0= IF
  178.                         " ERROR: Could not get file requester!"
  179.                         con.write.itl con.cr
  180.                 THEN
  181.     THEN
  182. ;
  183.  
  184.  
  185. : do.rt-filereq        ( -- t/f )
  186.     rt-filereq @
  187.     ASL-flg @ IF
  188.         RequestFile()
  189.     ELSE
  190.                 hail.txt >ABS  OVER ..! fr_Hail
  191.                 \ set default dir (make sure CMOVE's count is OK)
  192.                 dir.txt  OVER ..@ fr_Dir >REL  5 CMOVE
  193.                 FileRequest()
  194.         THEN
  195.         0= IF
  196.                 \ return is 0 => Cancel hit
  197.                 " Cancelled!" con.write.itl con.cr
  198.         FALSE
  199.     ELSE
  200.                 fr-file C@ 0= IF
  201.                         \ string empty => return key hit with
  202.                         \ no file selected
  203.                         " ERROR: No tool selected!" con.write.itl
  204.                         con.cr con.cr
  205.                         prt.it-instr
  206.                         FALSE
  207.                 ELSE
  208.                     TRUE
  209.                 THEN
  210.         THEN
  211. ;
  212.  
  213.  
  214. : close.fr-lib        ( -- )
  215.     ASL-flg @ IF
  216.          rt-filereq @ FreeAslRequest()
  217.         -ASL
  218.     ELSE
  219.         -ARP
  220.     THEN
  221. ;
  222.  
  223.  
  224. \ *** support ***
  225.  
  226. : rt.greeting        ( -- )
  227.     " Replace the DefaultTool of Project Icons." con.write.itl con.cr
  228.     " © Copyright by Richard Mazzarisi 1989, 1990, 1992" con.write.c3 con.cr
  229.     "          All rights reserved." con.write.c3 con.cr
  230.     "      Written in JForth Professional 2.0." con.write.c3 con.cr con.cr
  231. ;
  232.  
  233.  
  234. : prt.rt-instr        ( -- )
  235.     " Instructions:"  con.write con.cr
  236.     " 1 - Click on the icon for this program."  con.write con.cr
  237.     " 2 - Shift click on the Project icons to have their"  con.write con.cr
  238.     "     DefaultTool changed "  con.write
  239.     " and "  con.write.itl
  240.     " the icon for the Tool to"  con.write con.cr
  241.     "     be set as the DefaultTool.  Order is not important."  con.write con.cr
  242.     " 3 - "  con.write
  243.     " OR "  con.write.itl
  244.     " Shift click only on one or more Project icons;"  con.write con.cr
  245.     "     a file requester will appear allowing the"  con.write con.cr
  246.     "     DefaultTool to be selected."  con.write con.cr con.cr
  247.     " (NOTE: The author assumes no responsibility for any"
  248.     con.write con.cr
  249.     " damages resulting from the use of this program.)" con.write con.cr
  250. ;
  251.  
  252.  
  253. : check.if.tool     { wb-arg -- t/f }
  254. \ check if file in wb-arg is a tool
  255. \ this will abort if fed a drawer under WB; OK however under JazzBench
  256.     \ get file's path name
  257.     wb-arg get.full-path IF
  258.         PAD $it.get-icon
  259.         theIcon @ ..@ do_Type  WBTOOL =
  260.         it.abort-icon
  261.     ELSE
  262.         " ERROR: Could not get path for:" con.write.itl
  263.         wreq @ wb-arg ..@ wa_Name >REL ConPutStr()
  264.         it.abort
  265.     THEN
  266. ;
  267.  
  268.  
  269. : find.tool        ( wb-arg #args -- )
  270. \ sets toolarg to # of the first(!) Tool found; 0 if none found
  271.     0 toolarg !
  272.     \ go thru icons to find the Tool
  273.     1+  1  DO
  274.         DUP  SizeOf() WBArg  I *  +
  275.         check.if.tool IF
  276.             I toolarg !  LEAVE
  277.         THEN
  278.     LOOP
  279.     DROP
  280. ;
  281.  
  282.  
  283. : verify.tool-path    ( -- t/f )
  284. \ verify with user that path is OK
  285.     " DefaultTool path will be: " con.write con.cr
  286.     "    " con.write
  287.     pathstr con.write con.cr con.cr
  288.     " Is the DefaultTool path OK to use?"
  289.     " OK, do it!" " No, Cancel" $it.auto.request IF
  290.         " Click closebox to abort."  con.write
  291.         con.cr con.cr
  292.         TRUE
  293.     ELSE
  294.         " Cancelled!" con.write.itl con.cr
  295.         FALSE
  296.     THEN
  297. ;
  298.  
  299.  
  300. : do.requester        ( -- t/f )
  301. \ uses a file requester to get tool path
  302. \ returns relative pointer to filerequester structure or false
  303.     alloc.fr IF
  304.         do.rt-filereq
  305.     ELSE
  306.         FALSE
  307.     THEN
  308. ;
  309.  
  310.  
  311. : setup.pathstr     ( -- )
  312. \ writes path and tool name from file requester into pathstr
  313.     pathstr init.name
  314.     \ build directory name if one given
  315.     fr-dir  DUP C@ 0> IF
  316.         \ path is not empty
  317.         0COUNT    2DUP pathstr build.name
  318.         \ make sure this not a device name
  319.         1- + C@ DUP ASCII : = NOT  SWAP ASCII / = NOT  AND IF
  320.             \ ok to put in a '/'
  321.             " /" COUNT pathstr build.name
  322.         THEN
  323.     ELSE
  324.         DROP
  325.     THEN
  326.     \ now add file name
  327.     fr-file 0COUNT pathstr build.name
  328. ;
  329.  
  330.  
  331. : request.tool-path    ( -- t/f )
  332. \ get Tool via a file requester, set up string and check with user
  333. \ (probably should check if in fact a Tool was selected, but we have no icon)
  334.     open.fr-lib IF
  335.         do.requester  IF
  336.             setup.pathstr
  337.             verify.tool-path
  338.         ELSE
  339.             FALSE
  340.         THEN
  341.         close.fr-lib
  342.     ELSE
  343.         FALSE
  344.     THEN
  345. ;
  346.  
  347.  
  348. : find.tool-path    { wb-arg -- t/f }
  349. \ writes full path of tool into pathstr
  350.     wb-arg    toolarg @  SizeOf() WBArg *  +
  351.     get.full-path IF
  352.         PAD pathstr $MOVE
  353.         verify.tool-path
  354.     ELSE
  355.         " ERROR: Could not get path for the tool: " con.write.itl
  356.         wreq @    wb-arg toolarg @  SizeOf() WBArg *  + ..@ wa_Name >REL
  357.         ConPutStr() con.cr
  358.         FALSE
  359.     THEN
  360. ;
  361.  
  362.  
  363. : get.tool-path     ( wbarg -- t/f )
  364.     toolarg @ IF
  365.         find.tool-path
  366.     ELSE
  367.         \ no tool specified, use requester
  368.         DROP request.tool-path
  369.     THEN
  370. ;
  371.  
  372.  
  373. : replace.it        ( -- )
  374. \ replaces the DefaultTool only if the icon represents a Project
  375.     PAD $it.get-icon
  376.     theIcon @ ..@ do_Type  WBPROJECT = IF
  377. [ clone-it @ ] .IF
  378.         pathstr $SET-DEFAULT-TOOL
  379.         PAD $it.save-icon
  380. .ELSE
  381. \ don't really do it if we are testing things in the interpreter
  382.         it.abort-icon
  383. .THEN
  384.     ELSE
  385.         "    is not a project! Default tool not replaced"
  386.         con.write.itl con.cr con.cr
  387.         it.abort-icon
  388.     THEN
  389. ;
  390.  
  391.  
  392. : make.one-rplcmt     { wb-arg -- }
  393.     \ get file's path name
  394.     wb-arg get.full-path IF
  395.         "   " con.write
  396.         PAD con.write con.cr
  397.         replace.it
  398.     ELSE
  399.         " ERROR: Could not get path for project:" con.write.itl con.cr
  400.         "   " con.write
  401.         wreq @ wb-arg ..@ wa_Name >REL ConPutStr() con.cr
  402.     THEN
  403. ;
  404.  
  405.  
  406. : do.replacements    ( wb-arg #args -- )
  407.     \ go thru icons of the projects to be changed
  408.     \ skipping the tool
  409.     " Replacing the DefaultTool for:" con.write con.cr
  410.     1+  1  DO
  411.         I toolarg @ = NOT IF
  412.             DUP  SizeOf() WBArg  I *  +
  413.             make.one-rplcmt
  414.         THEN
  415.         \ check for stop action
  416.         ?CLOSEBOX IF LEAVE THEN
  417.     LOOP
  418.     DROP
  419.     con.cr " Done.  " con.write.itl
  420. ;
  421.  
  422.  
  423. \ *** main ***
  424.  
  425. : replacetool        ( -- )
  426.     ' prt.rt-instr IS prt.it-instr
  427.     ' open.rt-window IS open.it-window
  428.     open.it-things
  429.     cursor.off
  430.     rt.greeting
  431.     check.WB
  432.     2 check.num.args IF                                  ( #args )
  433.         \ get pointer to args
  434.         WBMESSAGE @ >REL ..@ sm_ArgList >REL  SWAP   ( wbarg #args )
  435.         2DUP find.tool
  436.         toolarg @ 0= NOT  OVER 2 <  AND  IF
  437.                     " Need to click on at least one project icon!"
  438.                     con.write.itl con.cr con.cr
  439.                     prt.rt-instr
  440.                     2DROP
  441.                 ELSE
  442.                     \ Ok to try to do it!
  443.                     OVER get.tool-path
  444.                         IF
  445.                                 do.replacements
  446.                         ELSE
  447.                                 2DROP
  448.                         THEN
  449.                 THEN
  450.     THEN
  451.     close.it-things
  452. ;
  453.  
  454.  
  455. : rt
  456.     replacetool
  457. ;
  458.  
  459.  
  460. clone-it @ .IF
  461.  
  462. initclone
  463. clone replacetool
  464. save-image replacetool ReplaceTool -icon
  465.  
  466. .THEN
  467.  
  468. CR CR ." Type 'rt' to run." CR CR
  469.