home *** CD-ROM | disk | FTP | other *** search
/ The Fred Fish Collection 1.5 / ffcollection-1-5-1992-11.iso / ff_disks / 300-399 / ff321.lzh / IconJ / source / AtatJ1_00.f next >
Text File  |  1990-02-27  |  10KB  |  269 lines
  1. \ AtatJ coUtility for use in IconJ environment
  2. \ Rich Franzen, 3 Feb 1990
  3. \ JForth Professional v2.01
  4. \
  5. \    Revision History
  6. \    0.2    added -dd option
  7. \    0.3    added CleanExit word, deferred as ErrorCleanUp
  8. \    0.31    made work buffer bigger & had Free-Icon close icon.library
  9. \    0.4    added -s option & fixed FindToolType for null tooltypes
  10. \    0.41    fixed .Command to properly show filepaths with spaces
  11. \    1.00    altered version number to reflect general release
  12. \
  13.  
  14. getmodule includes
  15.  
  16. include? DiskObject      ji:workbench/workbench.j
  17. include? WBstartup      ji:workbench/startup.j
  18. include? GetDiskObject()  ju:Icon-Support
  19. include? Lock()          ju:dos-support
  20.  
  21. anew task-AtatJ
  22.  
  23. 256 constant max_line        \ maximum script line length
  24.  
  25. variable op_detach        \ detach flag
  26. variable op_REXX        \ REXX flag
  27. variable op_CLI            \ CLI flag
  28. variable op_STARTUP        \ STARTUP flag
  29. variable myFIB            \ storage for pointer to FIB
  30. variable theToolTypes        \ storage for ToolTypes pointer
  31. variable theStrings        \ storage for new ToolType array + strings
  32. variable theScript        \ storage for SCRIPT= address
  33. variable string.addr        \ last location used for string text
  34. variable tool#            \ last tool number used
  35. variable +Script        \ offset within TIB to ScriptName
  36. variable Script_handle        \ handle for ScriptName
  37. variable +Info            \ offset within TIB to InfoName
  38. variable Info_handle        \ address of InfoFile memory buffer
  39.  
  40. code 4+  ( n -- n4+)        \ quick 4 +
  41.    4 #  tos dn  addq
  42.    inline   end-code
  43. code 4*  ( n -- n4*)        \ multiply by 4 quickly
  44.    2 #  tos dn  asl
  45.    inline   end-code
  46.  
  47. : ?0()  ( addr count -- adr2 | ff)    \ determine if range contains a 0
  48.    false  -rot                \ assume no 0 is present
  49.    dup if   over + swap do   i c@ 0= if   drop  i  leave   then   loop
  50.     else   2drop            \ case of 0-length string
  51.     then ;
  52.  
  53. : .Tab   9 emit ;        \ print tab character
  54. : .Command            \ print command name
  55.    tib  +Script @  type ;
  56. : .Usage            \ print usage message
  57.    f:3  .Command  ."  v1.00 by Rich Franzen, © 1990"  f:1  cr
  58.    ." Attaches a script to a project icon (xyz.info) file."  cr cr
  59.    ." Usage:  "  .Command  ."  ScriptFile [InfoFile] [-(r|c|s|d|dd)]"  cr
  60.    .Tab  ." use r switch when ScriptFile is ARexx script"  cr
  61.    .Tab  ." use c switch when ScriptFile requires keyboard input"  cr
  62.    .Tab  ." use s switch when s:IconJ-Startup is to be executed also"  cr
  63.    .Tab  ." use  d switch when detaching script from InfoFile"  cr
  64.    .Tab  ." use dd switch when duplicating script from InfoFile"  cr ;
  65. : .infoExit   .usage  quit ;    \ report info and exit
  66.  
  67. : ScriptFile  ( -- a_0$)    \ returns address of ScriptFile name
  68.    TIB  +Script @  + ;
  69. : InfoFile    ( -- a_0$)    \ returns address of InfoFile name
  70.    TIB  +Info @  + ;
  71. : ScriptName            \ get ScriptFile name from TIB
  72.    >in @  +Script !            \ save offset within TIB
  73.    fileword  dup oddw@ $ 013F = if   drop  .infoExit   then    \ when ?
  74.    dup c@ if
  75.     count  dup>r  ScriptFile  swap cmove      \ normal
  76.     0  ScriptFile r> +  c!              \ 0-terminate the string
  77.       else   drop  .infoExit              \ when zip
  78.       then ;
  79. : switches_off            \ initialize switches to off
  80.    op_detach off  op_REXX off  op_CLI off  op_STARTUP off ;
  81. : parse_switch  ( c)        \ parse single character of switch field
  82.    $ df and  case
  83.     ascii D of   -1 op_detach +!    endof   \ checks for double D's
  84.     ascii R of   op_REXX on        endof
  85.     ascii C of   op_CLI on        endof
  86.     ascii S of   op_STARTUP on    endof
  87.       endcase ;
  88. : @Switches  ( a$)        \ get switches from TIB
  89.    count  over c@ ascii - =  over 1 >  and if
  90.     over +  swap 1+ do   i c@ parse_switch   loop
  91.       else   2drop
  92.       then ;
  93. : Script>Dest            \ set DestInfoFile = ScriptFile
  94.    +Script @  +Info ! ;
  95. : InfoName            \ get DestInfoFile name and @Switches
  96.    >in @  +Info !            \ save offset within TIB
  97.    switches_off                \ initialize command switches
  98.    fileword  dup c@ 0= if        \ 2nd parameter absent
  99.     Script>Dest  drop
  100.       else                \ 2nd parameter present
  101.     dup 1+ c@  ascii - = if        \ 2nd parameter is switches
  102.         @Switches   Script>Dest
  103.       else                \ 2nd parameter is InfoName
  104.         count  dup>r  InfoFile  swap cmove
  105.         0  InfoFile  r> +  c!
  106.         fileword  @Switches        \ here for balanced activity
  107.       then
  108.       then ;
  109. : strip.info            \ strips ".info" from InfoFile 0string
  110.    0" .info"  5                \ addr count
  111.    InfoFile 0count +  5 -  dup>r    \ addr of last 5 bytes of InfoFile
  112.    text=? if   0 r@ c!   then   rdrop ;
  113.  
  114. : FindToolType()  ( a_toolTypes a_typeName -- a_0$)
  115.    over if   call>abs icon_lib FindToolType  if>rel
  116.       else   drop
  117.       then ;
  118. : MatchToolValue()  ( a_stringPointer a_subString -- f)
  119.    call>abs icon_lib MatchToolValue ;
  120. : $Get-Icon  ( a_0$)        \ bring diskobject into memory
  121.    GetDiskObject()  dup Info_handle !
  122.    dup 0= abort" Unable to open the ICON file."
  123.    ..@ do_ToolTypes  if>rel theToolTypes ! ;
  124. : Free-Icon            \ free diskobject
  125.    Info_handle @  ?dup if   FreeDiskObject()  Info_handle off   then
  126.    -icon ;                \ close icon.library
  127. : $Save-Icon  ( a_0$)        \ store diskobject onto disk
  128.    Info_handle @  ?dup if   PutDiskObject()   then
  129.    0= if   ."  Error while saving DiskObject. "   then
  130.    Free-Icon ;
  131. : ?abort~proj            \ abort if icon not project type
  132.    Info_handle @ ..@ do_Type
  133.    WBPROJECT - if
  134.     Free-Icon
  135.     ."  ICON file is not type PROJECT. "
  136.     abort
  137.     then ;
  138. : @ScriptFile  ( a_0$)        \ open ScriptFile
  139.    ScriptFile 0fopen  dup Script_handle !
  140.    dup 0= abort" Unable to open the ScriptFile."
  141.    MarkFclose ;
  142. : !ScriptFile            \ close ScriptFile
  143.    Script_handle @  dup unmarkfclose  fclose ;
  144. : GetMem  ( n)            \ allocate n bytes of memory
  145.    Memf_Public Memf_Clear or  swap AllocBlock
  146.    dup 0= abort" Insufficient memory."
  147.    theStrings ! ;
  148. : PutMem            \ return memory
  149.    theStrings @  ?dup if   FreeBlock   theStrings off   then ;
  150. : GetFIB            \ allocate a File Info Block
  151.    MemF_Public  sizeof() FileInfoBlock  AllocBlock
  152.    dup 0= abort" Insufficient memory."
  153.    MyFIB ! ;
  154. : PutFIB            \ free FIB
  155.    MyFIB @  ?dup if   FreeBlock   MyFIB off   then ;
  156. : CleanExit            \ insure everything gets released on aborts
  157.    Free-Icon  PutMem  PutFIB ;
  158.  
  159. : nTool  ( n -- aa)        \ return addr of pointer to nth ToolType
  160.    4*  theToolTypes @  + ;
  161. : find_SCRIPT            \ find & store SCRIPT= address
  162.    theTooltypes @  0" SCRIPT"  FindToolType()  theScript ! ;
  163. : ?.info  ( -- f)        \ is it a self-contained script?
  164.    false   theScript @
  165.    ?dup if   nip   0" .info"  MatchToolValue()   then ;
  166.  
  167. : 1stLine  ( -- n)        \ find nth tool, which contains SCRIPT=
  168.    theScript @  7 -  >abs  ( aa_of_SCRIPT_tool)  >r
  169.     -1  Begin   1+ dup nTool @  dup 0=  swap r@ =  or until
  170.     rdrop ;            \ alternatively finds 1st blank slot
  171. : xfrLine  ( a_0$)        \ transfer line from *.info to ScriptFile
  172.    Script_handle @  swap 0count  fwrite
  173.    0< abort" Unable to transfer line."
  174.    Script_handle @  10 femit ;
  175. : xfr>Script            \ transfer all lines to ScriptFile
  176.    1stLine
  177.    begin   1+ dup nTool @ if>rel
  178.       ?dup while   xfrLine   repeat
  179.    drop ;
  180.  
  181. : ExistsScript?            \ if ScriptFile exists, delete it?
  182.    ScriptFile Access_Read  Lock()
  183.    ?dup if   unLock()
  184.     cr  F:3  ScriptFile 0count type  F:1
  185.     ."  already exists.  Overwrite it (y/N)? "
  186.     key  BL or  ascii y  =
  187.     0= Abort" Ok, terminating."
  188.       then ;
  189. : ScriptSize  ( -- n)        \ return size in bytes of ScriptFile
  190.    ScriptFile Access_Read  Lock()
  191.    ?dup 0= abort" Unable to Lock() on ScriptFile."
  192.    dup myFIB @ examine()  0= abort" Unable to Examine() ScriptFile."
  193.    unLock()  myFIB @  ..@  fib_Size ;
  194. : next.addr  ( count -- addr)    \ compute location for next string
  195.    1+  negate                \ leave room for null
  196.    string.addr @ +  dup string.addr ! ;
  197. : next.tool  ( -- # of next free tool)
  198.    tool# @  1+  dup tool# ! ;
  199.  
  200. : !Tool  ( addr count)        \ store next tool
  201.    dup next.addr  dup>r swap dup>r cmove    \ xfr name to theStrings
  202.    0  r> r> +  c!                \ null terminate string
  203.    string.addr @ >abs  next.tool nTool ! ;    \ store string pointer
  204. : xfrTools            \ move tools from old to new location
  205.    theToolTypes @  dup if        \ transfer any that exist
  206.     theStrings @  1stLine dup>r cells  move
  207.       else   >r                \ when noToolTypes
  208.       then
  209.    theStrings @  theToolTypes !        \ don't need orig. tooltype array
  210.    " SCRIPT=.info" count >dos        \ build new SCRIPT= tooltype
  211.    op_Rexx @    if   " |REXX"     count +dos   then
  212.    op_CLI @     if   " |CLI"      count +dos   then
  213.    op_STARTUP @ if   " |STARTUP"  count +dos   then
  214.    theStrings @  dup sizemem +  1- string.addr !    \ init string.addr
  215.    r> 1- tool# !                    \ init tool#
  216.    dos0 0count !Tool ;
  217. : .Early  ( addr count)        \ explain early exit
  218.    cr  ."  Early exit due to: "
  219.    dup max_line = if   cr  .tab  ." line size too large. "   then
  220.    ?0() if   cr  .tab  ." ascii null within ScriptFile. "   then
  221.    tool# @  negate  tool# ! ;        \ to remember about early exit
  222. : xfr<script            \ xfr all lines from ScriptFile
  223.    xfrTools                \ init new ToolTypes array
  224.    tempbuff openfv drop            \ open sequential filebuffer
  225.    Begin   Script_handle @  tempbuff  MyFIB @  max_line ReadLine  ( a n|tf)
  226.     dup 0 >=  over max_line = 0=  and    \ not EOF & not too long
  227.     dup>r if   2dup ?0() not  r> and   else   r>   then    \ & no 0's
  228.     while   !Tool   repeat
  229.    tempbuff closefvread
  230.    dup 0< if   2drop   else   .Early   then ;
  231.  
  232. : @Icon                \ get icon & SCRIPT= address
  233.    InfoFile $Get-Icon ;
  234. : !Icon_SCRIPT            \ store icon with atatJed script
  235.    tool# @  0> if
  236.     theStrings @ >abs  Info_handle @ ..! do_ToolTypes  \ update tool_ptr
  237.     InfoFile $Save-Icon
  238.       else   Free-Icon            \ don't save when early exit
  239.       then ;
  240. : !Icon_noSCRIPT        \ delete SCRIPT= tool if it exists
  241.    theScript @  op_detach @ -2 = not  and if
  242.     1stLine nTool off        \ string deletion
  243.     InfoFile $Save-Icon        \ save truncated icon
  244.      else   Free-Icon            \ just release the icon's mem.
  245.      then ;
  246.  
  247. : AtatJ                \ top level command
  248.    ' CleanExit IS ErrorCleanup        \ help prevent mem-munging
  249.    ScriptName   InfoName  strip.info    \ parse cmd line
  250.    @Icon  ?abort~proj  find_SCRIPT    \ get icon from disk
  251.    op_detach @ if
  252.     ?.info if
  253.         ExistsScript?        \ delete existing script file?
  254.         new  @ScriptFile        \ open new script file
  255.         xfr>Script            \ xfr script lines
  256.         !ScriptFile            \ close script file
  257.       else   cr  ." InfoFile does not contain a script."
  258.       then
  259.     !Icon_noSCRIPT            \ close-down icon file
  260.       else
  261.     GetFIB                \ FIB for ScriptFile size
  262.     ScriptSize 3 2 */  256 +  GetMem    \ init newtool memory
  263.     old  @ScriptFile        \ open existing script file
  264.     xfr<Script            \ xfr script lines
  265.     !ScriptFile            \ close script file
  266.     !Icon_SCRIPT            \ close down icon file
  267.     PutMem   PutFIB            \ free-up memory
  268.       then ;
  269.