home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
OS/2 Professional
/
OS2PRO194.ISO
/
os2
/
prgramer
/
rexx
/
rdebug
/
debugrun.kex
< prev
next >
Wrap
Text File
|
1993-03-29
|
18KB
|
590 lines
/*H* DEBUGRUN.KEX 02-11-93 17:16*/
exit rtell('DEBUGRUN');
DEBUG: arg dbjump,dbusigl .
Signal On Error; Signal On Failure; Signal On Halt
Signal On Novalue; Signal On Notready; Signal ON Syntax
address value dbenvir
Parse Value 'next line' With dbnext
if dbtrc=-7 then do
Parse Value 1 With dbjump
call db1entry dbsigl
if dbtcode='80V'| dbtcode='80S' then dbnext='line' dbg
if dbsigl>dbsize then dbw=043; else dbw=045 /*!1*/
if dbtcode='80H' then call db0event 851 dbnext
else call db0event dbw dbnext;
call db1exit
if dberrorsw then Call ON ERROR; else Call OFF ERROR
drop dblist db1
if dbw2='' & dbnext='next line' then return 0
if dbg=dbgg then return 0
if dbjump=1 then signal value dbg
return 0;
end
else do
if sigl>dbsize then sigl=dbg
call db1entry sigl
if dbtcode='80V'| dbtcode='80S' then dbnext='line' dbg
call db0checkbp
if dbtrc=-7 then do
if dbtcode='80H' then
call db0event 851 dbnext
Else call db0event 041
end
call db1exit
if dberrorsw then Call ON ERROR; else Call OFF ERROR
drop dblist db1
if dbw2='' then return 0
if dbg=dbgg then return 0
if dbjump=1 then signal value dbg
end
return 0; DB0CHECKBP:
dbno=dbg%42+1
dbn=wordpos(dbg,'D' dbtbl.dbno)
dbtype=word('D' dbtbl.dbno,dbn+1)
if (dbproc<>'')+(dbstep?)>0 then do /*F*/
if dbproc=0 then dbcallstack=delword(dbcallstack,1,1) /*F*/
else dbcallstack=dbproc delword(dbcallstack,5) /*F*/
if dbstep? then do /*F*/
if dblevel0? then parse value 0 1 0 1 with, /*F*/
dbstep? dblogproc dblevel0? dbbreak? /*F*/
if dbnest=0 & dblogproc=0 then dblevel0?=1 /*F*/
else do /*F*/
if dbnest=1 then dblogproc=0 /*F*/
if dbproc=0 then dbnest=dbnest-1 /*F*/
else if dbproc<>'' then dbnest=dbnest+1 /*F*/
if dbnest<=0 then dbnest=0 /*F*/
if dbnest>0 then dbbreak?=0 /*F*/
end /*F*/
end /*F*/
dbproc='' /*F*/
end /*F*/
if dbwatchsw then if db2watch() then return db0dobp(030 dblist)
if db2count()=0 then return db0dobp()
if dbtrc=-7 then return -7 dbtrap
select
when dbtype='S' then do
call db3back dbg+1,dbg+1,'S'
dbtrc=dbw2
if dbtrc=-7 then return -7 dbtrap
dbg=dbw2
dbskip?=1;end
When (dbbreak?)+(dbresume=dbg)>0 then do
dbresume=0
return db0dobp(); end
when dbtype='E' then do
dbskip?=1
':'dbg; end
When dbtype='D' then do
if dbtracesw then call db1trace
dbskip?=0;end
Otherwise
If dbbreak? then nop /* do later */
call db0dobp 110 dbg
end
if dbtrc=-7 then return -7 dbtrap
return 0; DB0DOBP: arg dbno dbmsg2 /*!1*/
if dbtracesw then call db1trace
Parse Value 0 0 With dbcount dbskip?
if dbno<>'' then dbmsg=dbmsg rdbmsg(dbno dbmsg2) /*!1*/
do forever
call db1prompt dbmsg
if dbtrc=-7 then if dbtcode<>'80H' then call db0event 043 /*!1*/
else leave
end
return 0; DB0EVENT: parse arg dbmsgno dbrest
parse value dbtrap with dbint dbxme dbsigl dbtcode dbtrap
if dbinside? then dbmsg=dbmsg dbstr
if dbcallstack<>'' then dbtrap=dbtrap rdbmsg(842 dbcallstack)
dbmsg=dbmsg dbtrtn dbtrap
Parse Value 0 With dbtrc dbtrapp dbtrap
call db1prompt dbmsg rdbmsg(dbmsgno dbrest)
return 0; db1ENTRY: arg dbp
Parse Value dbp dbp With dbg dbgg
if dbtallysw then db.dbg=db.dbg+1 /*F*/
signal off novalue
parse value dbusigl'!'rc'!'result with dbuvarr
dbce '/FN/FT/MSGM/SCR/LSCR'
parse value fname.1''dbs''ftype.1 with dbfileid
if dbsys='OS2' then do /*O*/
dbdr=left(syssearchpath( 'path', '\nul'),2) /*O*/
address cmd dbdrs /* doesn't work */ /*O*/
dbdir=directory(dbdirs) /*O*/
end /*O*/
signal on novalue
dbcs 'SCR 1'
dbxx dbpath''dbsession '(PROF RDPROFIL'
dbc 'BOT'
dbcs 'SCR 2'
dbso 'TABCMDF'
dbxx dbpath''dbdfile '(PROF RDPROFIL'
dbcs 'VE 6' dblscr
return 0; db1EXIT:
call db2restore
dbxx dbpath''dbfileid '(prof rdprofil'
dbwait=dbsavew
if dbtype='D' | dbtype='B' then dblast=dbg
drop dbuvarr
if dbsys='OS2' then do /*O*/
address cmd dbdr /*O*/
call directory dbdirs; end /*O*/
return 0; db1PROMPT: parse arg dbmsg
Do forever
call db1msgs
if dbread?=1 then do
parse value rdbinit('/IN' dbinclude) with dbtrc dbtrap
dbstr=dbtrap
if dbtrc=-7 then return -7 dbtrap
if dbprgm='DEMO' then interpret rddemo(dbstr)
end
else do
parse value rdbui('!' dbfullsw dberrorsw dblogsw dbtracesw,
dbtallysw dbwatchsw dblimit dbwait dbwatch) with dbstr
parse value dbstr with dbtrc dbtrap
if dbtrc='ABORT' then do; 'EMSG ABORTING'; exit; end
end
if dbtrc=-7 then return -7 dbtrap
parse var dbstr dbw1 dbw2 dbrem
if dbw1='NOMSG' then do while dbw1='NOMSG'
parse var dbstr . . dbstr
parse var dbstr dbw1 dbw2 dbrem; end
if left(dbw1,1)='*' then iterate
dbcurfile=db8thisfile();
if dbcurfile=dbpath''dbdfile then dbinside?=1; else dbinside?=0
if left(dbw1,1)='=' then dbstr=dbm.dbq /*F*/
if left(dbw1,1)='&' then /*F*/
Parse Value dbstr'!'substr(dbstr,2) With dbcmsg'!'dbstr /*F*/
parse upper var dbstr dbw1 dbw2 dbrem
if dbm.dbq<>dbstr then do /*F*/
Parse Value dbq+1 dbq-11 With dbq dbqlast /*F*/
if dbq>10 then drop dbm.dbqlast /*F*/
dbm.dbq=dbstr;end /*F*/
if dblogsw then call db3log '**' dbstr
if dbtrc=-7 then return -7 dbtrap
trace value dbt.dbgt
if length(dbw1)=1 then call db1testor
else do
parse value rdbcmds(dbw1 1 dbfullsw dbpath) with dbtrc dbtrap
if dbtrc=-7 then return -7 dbtrap
Parse Value dbtrc dbtrap With dbn dbcmdstr
select
When dbn=1 then do
dbtrtn=dbcmdstr 'rDEBUG command'
interpret dbcmdstr
end
When dbn=2 then do
if dbinside? then do
dbtrtn= dbcmdstr 'restricted rDEBUG command'
interpret dbcmdstr
end
else dbmsg=dbmsg rdbmsg(115 dbdfile, 'press F4')
end
When dbn=3 then do
call db8shield "interpret dbstr"
end
otherwise call db1testor
end
end
if dbw1=1 then leave
if dbtrc=-7 then return -7 dbtrap;
end
call db1msgs
if dbtrc=-7 then return -7 dbtrap;
drop dbw1 dbrem dbcmdstr
return 0; db1MSGS:
if dbcmsg<>''then do
if length(dbcmsg)>dblscr-5&dbmsg=''then dbmsg=dbcmsg
else do
call db3log '*' strip(dbcmsg)
dbc 'CMSG *' dbstr; end
end
if dbmsg<>''then do
call db3log '*' strip(dbmsg); end
parse value '' with dbmsg dbcmsg
return 0; db1TESTOR:
dbi=pos('=',dbstr)
if dbi>1 then do
parse value substr(dbstr,1,dbi-1) with dbw1 dbw2 .
if dbw1<>'' & dbw2='' then do
dbtrtn= dbstr 'assignment statement'
interpret dbstr
end
else do
dbtrtn=dbstr 'xedit instruction'
interpret 'dbstr'
end
end
else call db8shield "interpret 'dbstr'"
dbw1=''
return 0; db1TRACE:
if dbskip?=0 & dblogproc=1 & dbresume=0 then do
if dblogsw&dblast>1 then do
dbtrace=substr(sourceline(dblast),dbuc)
call db3log '***' dbtrace
if dbtrc=-7 then return -7 dbtrap
call db3log dbtrace
drop dbtrace; end
end
':'dbg 'REFRESH'
return 0; DB2COUNT:
dbcount=dbcount+1 /*F*/
if dbcount>=dblimit then do /*F*/
dbcount=0
if dblimit<>1 then dbmsg=dbmsg rdbmsg(020 dblimit);end /*F*/
return dbcount
db2WATCH:
Parse Value dbwatch '!' With dbws'!'dblist
signal off novalue
do while dbws<>''
parse var dbws dbw dbws
if left(dbw,1)='(' then do
interpret "db1=" dbw
if db1=1 then dblist=dblist dbw; end
else do
db1=value(dbw)
if (db1<>dbprev.dbw)+(left(dbw2,2)='WA')>0 then
Parse Value db1'!!!'dblist dbw'='value(dbw)';' With dbprev.dbw'!!!'dblist
end
end
signal on novalue
dbrc=(dblist<>'')
return dbrc
db2RESTORE:
parse value dbuvarr with sigl'!'rc'!'result
return 0; db3BACK:
parse arg dbl, dbrange, dbtype , dbprompt
if dbl='' then dbl=dbg
dblabel=1
select
when dbtype ='S' then do
do dbl=dbl to dbrange until dblabel
dblabel=(substr(sourceline(dbl),dbuc-2,1)=':')
end
if dbl>dbl then dbl=dbl-1
end
when (dbtype='G')+ (dbtype='P')>0
then dblabel=(substr(sourceline(dbl),dbuc-2,1)=':')
otherwise dblabel=(substr(sourceline(dbl),dbuc-2,1)=':')
end
if datatype('0'dbl,'w')=0&dbl>dbsize then do
dbmsg=dbmsg rdbmsg(305 dbl); return 0;end
if dblabel & left(sourceline(dbl),5)='Call ' then ':'dbl
else do
if (dbl=1)+(dbtype='P')>0 then ':'dbl
else do
if dbjump= '1' then dbmsg=dbmsg rdbmsg(310 dbl)
else dbmsg=dbmsg rdbmsg(311 dbl)
dbl=0
if dbprompt<>'NOP' then call db1prompt dbmsg
end
end
return dbl;
db3LOG: parse arg dbss dbline
if dbxme<>'' then dbxme=''
dbce '/LSCR'
if lscreen.3<13 then dbscr=1; else dbscr=2
If dbscr=2 then dbso 'TABCMDB'
dbcurfile1=db8thisfile();
dbso 'TABCMDF'
dbcurfile2=db8thisfile();
dbso 'TABCMDB'
dbcs 'SCR1'
if dbcurfile1<>dbpath''dbsession then dbxx dbpath''dbsession '(PROF RDPROFIL'
dbc 'BOT'
do dbn=1 to 6 while dbline<>''
dbpos=pos(dbsep,' 'dbline) /*!1*/
if dbpos>0 then do
dbm = left(dbline,dbpos-2)
dbline = substr(dbline,dbpos+2); end /*!1*/
else do; dbm=dbline; dbline=''; end
if dbss='*'
then dbm='*' right(dbg,3) dbm
else if dbss='***' then dbm='*' right(dblast,3) dbm
else if dbss='**' then dbm=' ' dbm
else do
dbstr=db7pairs(' 'strip(dbss dbm,'T'))
call db2restore
dbstr=strip(dbstr)
dbstr="''"translate(dbstr,' ',dbtranslate)
call db8shield "interpret 'dbstr=' dbstr"
dbm=translate(db7pairs(dbstr),' ',dbtranslate)
if dbm='' then do
call db3logexit
return dbtrc dbtrap;end
if right(dbstr,1)=',' then dbstr=substr(dbstr,1,length(dbstr)-1)
dbm='*' right(dblast,3) dbm
end
if dbinside? then do
dbc 'INP' dbm
dbc 'PUT 1' dbpath''dbsession; end
else dbc 'MSG' dbm
end
call db3logexit
if dbinside?=0 then dbfc?=1
drop dbm db1 dbss dbline
return 0; db3logexit:
if dbcurfile1<>dbpath''dbsession then do
dbxx dbcurfile1 '(PROF RDPROFIL'
dbc 'MSG' rdbmsg(230); end
else dbc 'BOT'
dbcs 'SCR2'
dbso 'TABCMDF'
dbxx dbcurfile2 '(PROF RDPROFIL'
If dbscr=1 then dbso 'TABCMDB'
return 0; db4PREFIX: Procedure expose dbg dbmsg dbce dbcs line.1,
dbbreak? dbalt dbc dbuc dbupdate? dbtbl. dbdfile dbprof dbs dbenvir,
dbme dbsize dbtrc dbtrap dbtrapp dbpath dbinside? dbcallstack dbtrigger dbfullsw dberrorsw dblogsw,
dbtracesw dbtallysw dbwatchsw dblimit dbwait dbwatch
arg dbopt . dbw2 dbrem
dbce '/LINE'
if dbw2=-1 then do /*F*/
Parse Value dbw2%42+1 line.1 With dbno dbw2 /*F*/
if wordpos(dbw2,dbtbl.dbno)>0 then dbopt='DEBUG' /*F*/
else dbopt='BREAK';end /*F*/
if dbw2=''then do
dbw2=line.1; end
else if dbw2=0 then do;
dbbreak?=(dbbreak?=0);
if dbbreak? then dbw1='active'; else dbw1='cancelled'
dbmsg=dbmsg rdbmsg(411 dbw1)
return 0;end
dbmsg=dbmsg 'DBG410r' dbopt dbw2 dbrem
dbstr=dbopt dbw2 dbrem
if pos('-',dbw2 dbrem)>0 then dbstr=rdbmisc('/EXPAND' dbstr)
call db42delete dbstr
if dbtrc=-7 then return -7 dbtrap
call db43setcall dbopt dbstr
if dbtrc=-7 then return -7 dbtrap
parse value RDBPROF('/CTRL . 0' dbpath dbsize dbdfile'!'dbprof'!'dbuc'!',
dbfullsw dberrorsw dblogsw dbtracesw dbtallysw dbwatchsw,
dblimit dbwait dbwatch'!'dbstr) with dbtrc dbtrap
if dbtrc=-7 then return -7 dbtrap
dbmsg=dbmsg dbtrap
return 0; db42DELETE:
procedure expose dbtbl. dbtrigger dbme dbsize
arg . dbw dbws
do dbx=1 while dbw<>''
if datatype('0'dbw,'W')=0 then dbmsg=dbmsg rdbmsg(340 dbw)
else do
dbn=dbw%42+1
dbi=wordpos(dbw,dbtbl.dbn)
if dbi > 0 then dbtbl.dbn=delword(dbtbl.dbn,dbi,2); end
parse var dbws dbw dbws
end
return 0; db43SETCALL:
procedure expose dbtrigger dbjump dbmsg dbupdate? dbtbl. dbalt,
dbsize dbme dbcs dbce dbc dbuc dbsize dbtrigger dbjump,
dbenvir dbtrc dbtrap dbtrapp
arg dbopt . dbw dbws
dbce '/LINEN'
dbcs 'LINEN OFF'
dbinvalid=''
do dbx=1 while dbw<>''
if db3back(dbw,,'P','NOP')=0 then dbinvalid=dbinvalid dbw
else do
dbce '/CURL'
if substr(curline.3,dbuc-2,1)<>':' & dbopt='SKIP'
then dbinvalid=dbinvalid dbw
else do
if substr(curline.3,1,4)='Call' then do
dbc 'REP' overlay(left(dbopt,5),curline.3,6)
Parse Value dbalt+1 dbw%42+1 With dbalt dbno
if dbopt<>'DEBUG'&dbupdate?
then dbtbl.dbno=dbtbl.dbno dbw left(dbopt,1);end
end
end
parse var dbws dbw dbws
end
if dbinvalid<>''then dbmsg=dbmsg rdbmsg(520 dbinvalid)
dbcs 'LINEN' linend.1
return 0; db7PAIRS:
procedure expose dbsq dbdq dbtrigger dbsize dbme
parse arg str
do forever
Parse Value pos(dbsq,str) pos(dbdq,str) pos('/*',str),
With h i j
if h=0 then h=256
if i=0 then i=256
if j=0 then j=256
j=min(h,i,j)
if j=256 then leave
Parse Value 1 substr(str,j,1) With width delimiter
if delimiter='/' then Parse Value '*/' 2 With delimiter width
Parse Value substr(str,1,j-1)'!'substr(str,j+width),
With temp'!'str
j=pos(delimiter,str)
if j>0 then str=temp substr(str,j+width)
else do;str=temp;leave;end
end
return str
db8THISFILE:
address value dbenvir
dbce '/FILEID'
return fileid.1
db8SHIELD: parse arg dbin
signal off error
signal off syntax
signal off novalue
interpret dbin
signal on error
signal on syntax
signal on novalue
dbtrtn=''
return 0; ARG: procedure expose dbparms
arg dbn
if datatype('0'dbn,'N') then
dbn=word(dbparms,dbn)
else dbn=''
return dbn; DBI:
Signal ON ERROR; Signal On Failure; Signal ON HALT
Signal ON Novalue; Signal On Notready; Signal ON SYNTAX
call db9init
parse value 1 with dcall
call ON ERROR; Call On Failure; CALL ON HALT
/*!1Signal OFF Novalue; call On Notready; Signal ON SYNTAX*/
Signal ON Novalue; call On Notready; Signal ON SYNTAX
if dbtrc=-7 then do
call db0event 042
dbc 'EMSG ABORTING'; exit; end
address value dbdefenv
drop dbdefenv dbvars dbtemp
do forever
call db dbparms
dbbreak?=1
dbmsg=dbmsg rdbmsg(800)
dbcallstack=''
call debug 1, dbusigl
dbbreak?=0
end
return 0; db9INIT:
parse value 0 1 0 0 1 with dbbreak? dbinside? dbstep? dbnest dblogproc
parse value 0 0 0 1 with dbfc? dbrestart? dbupdate? dbsyntax?
parse value 1 0 'o ?r' with dbjump dbgt dbt.0 dbt.1
parse value 0 0 0 50 0 0 with dblevel0? dbskip? dbq dblimit dbalt dblast
parse value 0 0 'rc result 1' with dbusigl dbtrigger rc result sigl
parse value 0 "'" '"' 0 0 with dbresume dbsq dbdq dbqlast db.
Parse Value '' With dbprev. dbw2 dbmsg dbcmsg dbtbl. dbcallstack dbproc dbm.
Parse Value '' With dbtrc dbtrapp dbtrtn dbwatch dbxme dbtcode dbstr
dbtranslate='*,/+-%()=><:;&\'
Parse Value 'COMMAND SET!COMMAND X!COMMAND EXT' With dbcs'!'dbxx'!'dbce
Parse Value 'COMMAND!COMMAND SOS' With dbc'!'dbso
dbsep='~' /*C*/
dbsep=' ' /*!1 ascii 255 */ /*NC*/
Parse Value rdbvars() with dbtrc dbtrap
if dbtrc=-7 then return -7 dbtrap
interpret dbtrc dbtrap
dbme=dbdfile
dbce '/OPSYS'
dbsys=opsys.1
/*if dbsys='OS2' then do drop /*O*/
dbdrs=left(syssearchpath( 'path', '\nul'),2) /*O*/
dbdirs=directory(dbdirs); end /*O*/*/
dbline=8
dbxx dbpath''dbprof '(PROF RDPROFIL'
Signal OFF Error
':'dbline
do dbx=1 to 25 until rc<>0
dbce '/CURL'
parse var curline.3 dbn dbrem
parse upper var dbn dbn
if datatype(dbn,'w') then dbtbl.dbn=strip(dbrem,'t')
else if dbn='WATCH' then dbwatch=dbrem
'+1'
end dbx
'QQ'
Signal ON Error
parse value rdbinit('/FI D' dbpath dbsize'!'dblogsw'!'dbuc'!'dbtest?,
'!'dbsession'!'dbdfile'!'dbvars) with dbtrc dbtrap
if dbtrc=-7 then return -7 dbtrap
dbce '/LSCR'
dblscr=lscreen.2
parse value rdbcmds('DB9PREFIX 5' dbfullsw dbpath) with dbtrc dbtrap
if dbtrc=-7 then return -7 dbtrap
interpret dbtrap
call db2watch
if dbtrc=-7 then return -7 dbtrap
parse value dbwait 1 0 with dbsavew dbupdate? dbalt dbw2 dbtemp
dbmsg=rdbmsg(112 date() time())
dbc 'sos alarm'
':1 X' dbpath''dbinvoke '(PROF RDPROFIL'
return 0
ERROR: return db9trap(sigl '80E' sourceline(sigl)'~')
FAILURE: return db9trap(sigl '80F' sourceline(sigl)'~')
HALT: return db9trap(sigl '80H')
NOTREADY: return db9trap(sigl '80R' sourceline(sigl)'~')
NOVALUE:
call db9trap sigl '80V'
call debug dbg
if dbg>dbsize then return -7 dbtrap
signal value dbg
SYNTAX:
call db9trap sigl '80S' errortext(rc)'~'sourceline(sigl)'~'
call debug dbg
if dbg>dbsize then return -7 dbtrap
signal value dbg
db9TRAP:
if dbtrc=-7 then dbtrapp=dbtrap
parse arg dbsigl dbtcode dbtrest
dbtrap = dbtrapp 1 dbme dbsigl dbtcode rdbmsg(dbtcode dbme dbsigl) dbtrest
dbtrc=-7
sigl=dbsigl
if dbsigl<dbsize then call debug 1
return -7 dbtrap