home *** CD-ROM | disk | FTP | other *** search
/ Amiga MA Magazine 1998 #6 / amigamamagazinepolishissue1998.iso / coders / jËzyki_programowania / logo / powerlogo / utilities / arexx-support next >
Text File  |  1992-11-10  |  12KB  |  365 lines
  1.  
  2. unbury "arexx-names
  3. make "arexx-names [ arexx-names
  4.    host-port-demon reply-port-demon
  5.    add-function-host remove-function-host
  6.    command command-async command-op
  7.    command-string command-string-async command-string-op
  8.    function function-async function-op
  9.    clean-quit send-sync send-operation mp-error
  10.    create-message delete-message ]
  11. unbury :arexx-names
  12.  
  13. pprop "startup-data "keepers se  [ async-message-list
  14.                                  ] gprop "startup-data "keepers
  15.  
  16.  
  17. ;  ***************************************************************
  18. ;  ***   ARexx support
  19. ;  ***************************************************************
  20.  
  21. ;  This allows LOGO to act as a command host and function host for ARexx.
  22. ;  LOGO gets a list from the message and 'run's it.
  23.  
  24. make "host-port-demon [
  25.    procedure [ [ ] [ ]
  26.       [  :m-packet :m-action :m-text :rc1 :rc2 :m-cc :m-cf :i ] ]
  27.    make "m-packet getmessage
  28.    make "m-action ( peek 4 :m-packet 7 )
  29.    make "m-text convertstring ( peek 0 :m-packet 10 )
  30.    make "rc1 0
  31.    make "rc2 0
  32.    make "m-cc  if and   >= :m-action 16777216         ; *** command code
  33.                         < :m-action 33554432
  34.                [  make "m-action - :m-action 16777216
  35.                   "COMM ]                                ; command
  36.                [  if and   >= :m-action 33554432
  37.                            < :m-action 50331648
  38.                   [  make "m-action - :m-action 33554432
  39.                      "FUNC ]                             ; function
  40.                   [  "ERROR ] ]                          ; ???????
  41.    if >= :m-action 262144 [ make "m-action - :m-action 262144 ] [ ]
  42.    make "m-cf  if and   >= :m-action 131072           ; *** command flag
  43.                         < :m-action 262144
  44.                [  make "m-action - :m-action 131072
  45.                   "RESULT ]                              ; result
  46.                [  0 ]                                    ; no result
  47.    if >= :m-action 65536 [ make "m-action - :m-action 65536 ] [ ]
  48.    if ( and    >= :m-action 0
  49.                < :m-action 16
  50.                not = :m-cc "ERROR )
  51.    [  if = :m-cc "FUNC           ; *** if function process argstrings
  52.       [  make "i 11
  53.          repeat :m-action
  54.          [  make "m-text   se    :m-text
  55.                                  convertstring ( peek 0 :m-packet :i )
  56.             make "i + 1 :i ]
  57.          make "m-text lput ") :m-text
  58.          make "m-text fput "( :m-text ] [ ]
  59.       repeat 1
  60.       [  catch "error
  61.          [  if = :m-cf "RESULT   ; *** run the message
  62.             [  make "rc2 ( allocstring run :m-text false ) ]
  63.             [  run :m-text ]
  64.             break ]
  65.          make "rc1 10            ; *** process errors?
  66.          make "rc2 first error ] ]
  67.    [  make "rc1 10
  68.       make "rc2 100 ]
  69.    if =0 :rc1 [ ]
  70.    [  mp-error    [ *** WARNING! Incoming message error! *** ]
  71.                   hostport :m-text :rc1 :rc2
  72.       ( pr [ Action code: ] ( peek 4 :m-packet 7 ) )
  73.       if = :rc2 100 [ pr [ ] ] [ poerror ] ]
  74.    ( poke 4 :m-packet :rc1 8 )   ; *** send reply 
  75.    ( poke 4 :m-packet :rc2 9 )
  76.    replymessage :m-packet ]
  77.  
  78.  
  79. ;  reply-port-demon cleans up after asynchronous messages.
  80.  
  81. make "reply-port-demon [
  82.    procedure [ [ :m-packet ] [ ] [ :temp ] ]
  83.    if memberp :m-packet :async-message-list
  84.    [  while [ not emptyp :async-message-list ]
  85.       [  if = :m-packet first :async-message-list
  86.             [ ]
  87.             [ make "temp fput first :async-message-list :temp ]
  88.          make "async-message-list bf :async-message-list ]
  89.       make "async-message-list :temp
  90.       delete-message :m-packet ]
  91.    [  pr [ ]
  92.       pr [ *** WARNING! Unrecognized asyncronous reply! *** ]
  93.       pr [ ] ] ]
  94.  
  95.  
  96. ;  ***************************************************************
  97.  
  98. ;  Tell ARexx that we are a function host.
  99.  
  100. make "add-function-host [
  101.    procedure [ [ ] [ :pri ] [ :m-packet :r ] ]
  102.    if = @0 findport "REXX
  103.       [ pr [ ] pr [ ERROR! ARexx is not active! ] pr [ ] stop ] [ ]
  104.    if emptyp :pri [ make "pri -50 ] [ ]
  105.    make "m-packet create-message hostport se [ ] :pri [ ] [ ] 117440512
  106.    send-sync "REXX :m-packet
  107.    make "r ( peek 4 :m-packet 8 )
  108.    if >0 :r [ pr [ ] pr [ ERROR! Can't add function host! ] pr [ ] ] [ ]
  109.    delete-message :m-packet ]
  110.  
  111. ;  Tell ARexx that we are no longer a function host.
  112.  
  113. make "remove-function-host [
  114.    procedure [ [ ] [ ] [ :m-packet :r ] ]
  115.    if = @0 findport "REXX [ stop ] [ ]
  116.    make "m-packet create-message hostport [ ] [ ] [ ] 150994944
  117.    send-sync "REXX :m-packet
  118.    make "r ( peek 4 :m-packet 8 )
  119.    if >0 :r [ pr [ ] pr [ ERROR! function host not found! ] pr [ ] ] [ ]
  120.    delete-message :m-packet ]
  121.  
  122.  
  123. ;  ***************************************************************
  124.  
  125. ;  Procedures to communicate with ARexx, or any other program with
  126. ;  an ARexx compatible message port.
  127.  
  128. ;  LOGO command to send an ARexx command.
  129.  
  130. ;  command        text ( port-name host-name file-ext )
  131. ;           text =   Word or list containing instruction to be run
  132. ;                    by the command destination.
  133. ;           port-name = Name of destination port, default 'REXX'.
  134. ;           host-name = Name of port to get commands back from ARexx,
  135. ;                       default output of 'hostport'.
  136. ;           file-ext =  File name extension ARexx will use to find
  137. ;                       command, default 'LOGO'.
  138.  
  139. make "command [
  140.    procedure [    [ :m-text ]
  141.                   [ :port-name :host-name :file-ext ]
  142.                   [ :m-packet ] ]
  143.    make "m-packet create-message :m-text [ ] :host-name :file-ext 16777216
  144.    if emptyp :port-name [ make "port-name "REXX ] [ ]
  145.    send-sync :port-name :m-packet
  146.    make "result1 ( peek 4 :m-packet 8 )
  147.    make "result2 ( peek 4 :m-packet 9 )
  148.    delete-message :m-packet ]
  149.  
  150.  
  151. ;  LOGO command to send an ARexx string command.
  152.  
  153. make "command-string [
  154.    procedure [    [ :m-text ]
  155.                   [ :port-name :host-name :file-ext ]
  156.                   [ :m-packet ] ]
  157.    make "m-packet create-message :m-text [ ] :host-name :file-ext 17039360
  158.    if emptyp :port-name [ make "port-name "REXX ] [ ]
  159.    send-sync :port-name :m-packet
  160.    make "result1 ( peek 4 :m-packet 8 )
  161.    make "result2 ( peek 4 :m-packet 9 )
  162.    delete-message :m-packet ]
  163.  
  164.  
  165. ;  LOGO command to send an ARexx command asynchronously.
  166.  
  167. make "command-async [
  168.    procedure [    [ :m-text ]
  169.                   [ :port-name :host-name :file-ext ]
  170.                   [ :m-packet ] ]
  171.    make "m-packet create-message :m-text [ ] :host-name :file-ext 16777216
  172.    make "async-message-list fput :m-packet :async-message-list
  173.    if emptyp :port-name [ make "port-name "REXX ] [ ]
  174.    sendmessage :port-name :m-packet ]
  175.  
  176.  
  177. ;  LOGO command to send an ARexx string command asynchronously.
  178.  
  179. make "command-string-async [
  180.    procedure [    [ :m-text ]
  181.                   [ :port-name :host-name :file-ext ]
  182.                   [ :m-packet ] ]
  183.    make "m-packet create-message :m-text [ ] :host-name :file-ext 17039360
  184.    make "async-message-list fput :m-packet :async-message-list
  185.    if emptyp :port-name [ make "port-name "REXX ] [ ]
  186.    sendmessage :port-name :m-packet ]
  187.  
  188.  
  189. ;  LOGO operation to send an ARexx command, and output a result.
  190.  
  191. make "command-op [
  192.    procedure [    [ :m-text ]
  193.                   [ :port-name :host-name :file-ext ]
  194.                   [ :m-packet :out ] ]
  195.    make "m-packet create-message :m-text [ ] :host-name :file-ext 16908288
  196.    send-operation
  197.    if =0 :result1
  198.    [  output :out ]
  199.    [  mp-error    [ *** Error at command destination! *** ]
  200.                   :port-name :m-text :result1 :result2 ] ]
  201.  
  202.  
  203. ;  LOGO operation to send an ARexx string command, and output a result.
  204.  
  205. make "command-string-op [
  206.    procedure [    [ :m-text ]
  207.                   [ :port-name :host-name :file-ext ]
  208.                   [ :m-packet :out ] ]
  209.    make "m-packet create-message :m-text [ ] :host-name :file-ext 17170432
  210.    send-operation
  211.    if =0 :result1
  212.    [  output :out ]
  213.    [  mp-error    [ *** Error at command destination! *** ]
  214.                   :port-name :m-text :result1 :result2 ] ]
  215.  
  216.  
  217. ;  LOGO command to send an ARexx function.
  218.  
  219. ;  function       text args ( port-name host-name file-ext )
  220. ;           text =   Word or list containing instruction to be run
  221. ;                    by the command destination.
  222. ;           args =   List containing function inputs.
  223. ;           port-name = Name of destination port, default 'REXX'.
  224. ;           host-name = Name of port to get commands back from ARexx,
  225. ;                       default output of 'hostport'.
  226. ;           file-ext =  File name extension ARexx will use to find
  227. ;                       command, default 'LOGO'.
  228.  
  229. make "function [
  230.    procedure [    [ :m-text :m-args ]
  231.                   [ :port-name :host-name :file-ext ]
  232.                   [ :m-packet ] ]
  233.    make "m-packet create-message
  234.                      :m-text :m-args :host-name :file-ext 33554432
  235.    if emptyp :port-name [ make "port-name "REXX ] [ ]
  236.    send-sync :port-name :m-packet
  237.    make "result1 ( peek 4 :m-packet 8 )
  238.    make "result2 ( peek 4 :m-packet 9 )
  239.    delete-message :m-packet ]
  240.  
  241.  
  242. ;  LOGO command to send an ARexx function asynchronously.
  243.  
  244. make "function-async [
  245.    procedure [    [ :m-text :m-args ]
  246.                   [ :port-name :host-name :file-ext ]
  247.                   [ :m-packet ] ]
  248.    make "m-packet create-message
  249.                      :m-text :m-args :host-name :file-ext 33554432
  250.    make "async-message-list fput :m-packet :async-message-list
  251.    if emptyp :port-name [ make "port-name "REXX ] [ ]
  252.    sendmessage :port-name :m-packet ]
  253.  
  254.  
  255. ;  LOGO operation to send an ARexx function, and output a result.
  256.  
  257. make "function-op [
  258.    procedure [    [ :m-text :m-args ]
  259.                   [ :port-name :host-name :file-ext ]
  260.                   [ :m-packet :out ] ]
  261.    make "m-packet create-message
  262.                      :m-text :m-args :host-name :file-ext 33685504
  263.    send-operation
  264.    if =0 :result1
  265.    [  output :out ]
  266.    [  mp-error    [ *** Error at function destination! *** ]
  267.                   :port-name :m-text :result1 :result2 ] ]
  268.  
  269.  
  270. ;  ***************************************************************
  271.  
  272.  
  273. make "clean-quit [
  274.    procedure [ ]
  275.    while [ messagep ] [ replymessage getmessage ]
  276.    while [ replyp ] [ pr getreply ]
  277.    remove-function-host
  278.    quit ]
  279.  
  280.  
  281. make "send-sync [
  282.    procedure [ [ :port-name :m-packet ] [ ] [ :r-packet ] ]
  283.    whenreply [ ]
  284.    sendmessage :port-name :m-packet
  285.    while [ true ]
  286.    [  sleep
  287.       if replyp
  288.       [  make "r-packet getreply
  289.          if = :r-packet :m-packet [ ]
  290.          [  reply-port-demon :m-packet ]
  291.          break ] [ ] ] ]
  292.    whenreply [ reply-port-demon getreply ]
  293.  
  294.  
  295. make "send-operation [
  296.    procedure [ ]
  297.    if emptyp :port-name [ make "port-name "REXX ] [ ]
  298.    send-sync :port-name :m-packet
  299.    make "result1 ( peek 4 :m-packet 8 )
  300.    if =0 :result1
  301.    [  make "result2 ( peek 0 :m-packet 9 )
  302.       make "out convertstring :result2
  303.       ( freemem :result2 false )
  304.       make "result2 0 ]
  305.    [  make "result2 ( peek 4 :m-packet 9 ) ]
  306.    delete-message :m-packet ]
  307.  
  308.  
  309. make "mp-error [
  310.    procedure [ [ :e :port-name :m-text :r1 :r2 ] ]
  311.    pr [ ]
  312.    pr :e
  313.    ( pr [ Port:\  \  \  \   ] :port-name )
  314.    ( pr [ Message: \  \  ] :m-text )
  315.    ( pr [ Error level: ] :r1 )
  316.    ( pr [ Error code:\  ] :r2 ) ]
  317.  
  318.  
  319. make "create-message [
  320.    procedure [    [ :m-text :m-args
  321.                     :host-name :file-ext :action ] [ ]
  322.                   [ :m-packet :i ] ]
  323.    if emptyp :host-name [ make "host-name hostport ] [ ]
  324.    if emptyp :file-ext [ make "file-ext "LOGO ] [ ]
  325.    make "m-packet allocmem 128
  326.    ( poke 2 :m-packet 128 9 )
  327.    make "i 0
  328.    while [ and    not emptyp :m-args
  329.                   < :i 15 ]
  330.    [  ( poke 4 :m-packet allocstring first :m-args + 11 :i )
  331.       make "m-args bf :m-args
  332.       make "i + 1 :i ]
  333.    ( poke 4 :m-packet ( + :action :i ) 7 )
  334.    ( poke 4 :m-packet allocstring :m-text 10 )
  335.    ( poke 4 :m-packet allocstring :host-name 27 )
  336.    ( poke 4 :m-packet allocstring :file-ext 28 )
  337.    make "result1 0
  338.    make "result2 0
  339.    output :m-packet ]
  340.  
  341.  
  342. make "delete-message [
  343.    procedure [ [ :m-packet ] [ ] [ :i ] ]
  344.    make "i 10
  345.    repeat 16
  346.    [  freemem ( peek 0 :m-packet :i )
  347.       make "i + 1 :i ]
  348.    freemem ( peek 0 :m-packet 27 )
  349.    freemem ( peek 0 :m-packet 28 )
  350.    freemem :m-packet ]
  351.  
  352.  
  353.  
  354. ; *********************************************************************
  355.  
  356. bury :arexx-names
  357. whenmessage [ host-port-demon ]
  358. whenreply [ reply-port-demon getreply ]
  359. make "result1 0
  360. make "result2 0
  361. make "async-message-list [ ]
  362. add-function-host
  363.  
  364.  
  365.