OS/2 Professional/OS2PRO194.ISO/os2/prgramer/rexx/rdebug/debugrun.kex

Text File | 1993-03-29 | 17.7 KB | 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