home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Frozen Fish 1: Amiga
/
FrozenFish-Apr94.iso
/
bbs
/
alib
/
d5xx
/
d516
/
rexxview.lha
/
RexxView
/
rexxview.f
< prev
Wrap
Text File
|
1991-07-20
|
7KB
|
275 lines
\ RexxView by Martin Kees
\ JForth REXX peeker
\ CLI utility to monitor REXX message traffic
\ Usage: rexxview outfile
\ Terminate by sending: closerexxview to REXX port
\ 3/JUN/91
\ Freely Distributable
getmodule includes
include? addport() ju:exec_support
anew task_rexxview
0" REXX" 0string RXSDIR
:STRUCT RexxMsg
STRUCT Message rm_Node ( EXEC message structure )
APTR rm_TaskBlock ( pointer to global structure )
APTR rm_LibBase ( library base )
LONG rm_Action ( command [action] code )
LONG rm_Result1 ( primary result [return code] )
LONG rm_Result2 ( secondary result )
( %?) 16 4 * BYTES rm_Args ( argument block [ARG0-ARG15] )
APTR rm_PassPort ( forwarding port )
APTR rm_CommAddr ( host address [port name] )
APTR rm_FileExt ( file extension )
LONG rm_Stdin ( input stream [filehandle] )
LONG rm_Stdout ( output stream [filehandle] )
LONG rm_avail ( future expansion )
;STRUCT
( size: 128 bytes )
15 constant MAXRMARG ( maximum arguments )
( Command [action] codes for message packets )
$ 01000000 constant RXCOMM ( a command-level invocation )
$ 02000000 constant RXFUNC ( a function call )
$ 03000000 constant RXCLOSE ( close the port )
$ 04000000 constant RXQUERY ( query for information )
$ 07000000 constant RXADDFH ( add a function host )
$ 08000000 constant RXADDLIB ( add a function library )
$ 09000000 constant RXREMLIB ( remove a function library )
$ 0A000000 constant RXADDCON ( add/update a ClipList string )
$ 0B000000 constant RXREMCON ( remove a ClipList string )
$ 0C000000 constant RXTCOPN ( open the trace console )
$ 0D000000 constant RXTCCLS ( close the trace console )
( Command modifier flag bits )
16 constant RXFB_NOIO ( suppress I/O inheritance? )
17 constant RXFB_RESULT ( result string expected? )
18 constant RXFB_STRING ( program is a "string file"? )
19 constant RXFB_TOKEN ( tokenize the command line? )
20 constant RXFB_NONRET ( a "no-return" message? )
( Modifier flags )
1 RXFB_RESULT << constant RXFF_RESULT
1 RXFB_STRING << constant RXFF_STRING
1 RXFB_TOKEN << constant RXFF_TOKEN
1 RXFB_NONRET << constant RXFF_NONRET
1 RXFB_NOIO << constant RXFF_NOIO
$ FF000000 constant RXCODEMASK
$ 0000000F constant RXARGMASK
0 value rxpri
0 value myport
0 value rxport
0 value rmsg
0 value ofile
: FORBID() ( -- )
callvoid exec_lib forbid
;
: PERMIT() ( -- )
callvoid exec_lib permit
;
: dscanlist ( port -- rexxport true | 0 )
begin
s@ ln_succ dup
IF dup s@ ln_name ?dup
IF
RXSDIR 4 compare
IF-NOT true exit
THEN
THEN
THEN
dup
until-not
;
\ Not needed after I found that the message port list
\ is priority sorted but ...
: uscanlist ( port -- rexxport true | 0 )
begin
s@ ln_pred dup
IF dup s@ ln_name ?dup
IF
RXSDIR 4 compare
IF-NOT true exit
THEN
THEN
THEN
dup
until-not
;
: Openmyport ( -- flag )
0 -> myport
forbid()
RXSDIR findport() dup -> rxport
IF rxport ..@ ln_pri -> rxpri
RXSDIR rxpri 1+ Createport() -> myport
THEN
permit()
myport
;
: Closemyport ( -- )
myport ?dup IF deleteport()
0 -> myport
THEN
;
: msg>taskname ( msg -- 0$task )
s@ mn_replyport
s@ mp_SigTask
s@ ln_name
;
: msg>arg0 ( msg -- 0str )
.. rm_args @ >rel
;
: fcr
10 pad c! ofile pad 1 fwrite drop
;
: >ofile ( srt -- )
ofile swap count fwrite drop
;
: ?0type ( 0str str -- )
ofile swap count fwrite drop
0count
?dup IF ofile -rot fwrite drop
ELSE drop ofile " Null" fwrite drop
THEN
fcr
;
: term.rv ( msg -- )
replymsg()
begin myport getmsg() ?dup
while replymsg()
repeat
closemyport
ofile fclose
;
: SendToRexx ( msg -- flag )
forbid()
myport dscanlist
?dup IF-NOT myport uscanlist
THEN
IF swap putmsg() true
ELSE false
THEN
permit()
IF-NOT
" REXX port closed!" >ofile
term.rv
THEN
;
: aboutmsg
ofile " RexxView by Martin Kees " count fwrite drop fcr
ofile " (c) 1991 M C Kees" count fwrite drop fcr
ofile " Freely Distributable" count fwrite drop fcr
;
: .action ( msg -- )
" Action: " swap
..@ rm_action RXCODEMASK AND
CASE
RXCOMM OF 0" RXCOMM"
ENDOF
RXFUNC OF 0" RXFUNC"
ENDOF
RXCLOSE OF 0" RXCLOSE"
ENDOF
RXQUERY OF 0" RXQUERY"
ENDOF
RXADDFH OF 0" RXADDFH"
ENDOF
RXADDLIB OF 0" RXADDLIB"
ENDOF
RXREMLIB OF 0" RXREMLIB"
ENDOF
RXADDCON OF 0" RXADDCON"
ENDOF
RXREMCON OF 0" RXREMCON"
ENDOF
RXTCOPN OF 0" RXTCOPN"
ENDOF
RXTCCLS OF 0" RXTCCLS"
ENDOF
0" UNKNOWN" swap
ENDCASE
swap ?0type
;
: .modifier ( msg -- )
" Modifier: " >ofile
..@ rm_action
dup RXFF_RESULT and IF " RXFB_RESULT " >ofile
THEN
dup RXFF_STRING and IF " RXFB_STRING " >ofile
THEN
dup RXFF_TOKEN and IF " RXFB_TOKEN " >ofile
THEN
dup RXFF_NONRET and IF " RXFB_NONRET " >ofile
THEN
dup RXFF_NOIO and IF " RXFB_NOIO " >ofile
THEN
drop fcr
;
: rexxview ( -- )
new fileword
dup 1+ c@ ascii ? = over c@ 0= OR
IF drop cr
." Usage: rexxview OutputFileName" cr
." Terminate by sending to REXX: closerexxview" cr
exit
THEN
$fopen -> ofile
ofile
IF
openmyport
IF aboutmsg
BEGIN
myport waitport() drop
myport getmsg() -> rmsg
rmsg msg>taskname " From Task: " ?0type
rmsg .action
rmsg .modifier
rmsg msg>arg0
dup " Arg0: " ?0type fcr
0" closerexxview" 0count compare
IF-NOT rmsg term.rv
exit
THEN
rmsg sendtorexx
AGAIN
ELSE ofile fclose
rxport IF-NOT ." REXX not found " cr exit
THEN
THEN
myport IF-NOT ." No memory for RexxView port!" cr exit
THEN
ELSE
." Couldn't open output file" cr
THEN
;