home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 18 REXX / 18-REXX.zip / rdebug21.zip / DEBUGRUN.KEX < prev    next >
Text File  |  1993-03-29  |  18KB  |  590 lines
  1. /*H* DEBUGRUN.KEX 02-11-93 17:16*/
  2.  exit rtell('DEBUGRUN');
  3.  DEBUG: arg dbjump,dbusigl .
  4.  Signal On Error;   Signal On Failure;  Signal On Halt
  5.  Signal On Novalue; Signal On Notready; Signal ON Syntax
  6.  address value dbenvir
  7.  Parse Value 'next line' With dbnext
  8.  if dbtrc=-7 then do
  9.    Parse Value 1 With dbjump
  10.    call db1entry dbsigl
  11.    if dbtcode='80V'| dbtcode='80S' then dbnext='line' dbg
  12.    if dbsigl>dbsize then dbw=043; else dbw=045   /*!1*/
  13.    if dbtcode='80H' then call db0event 851 dbnext
  14.    else call db0event dbw dbnext;
  15.    call db1exit
  16.    if dberrorsw then Call ON ERROR; else Call OFF ERROR
  17.    drop dblist db1
  18.    if dbw2='' & dbnext='next line' then return 0
  19.    if dbg=dbgg then return 0
  20.    if dbjump=1 then signal value dbg
  21.    return 0;
  22.  end
  23.  else do
  24.  
  25.    if sigl>dbsize then sigl=dbg
  26.    call db1entry sigl
  27.    if dbtcode='80V'| dbtcode='80S' then dbnext='line' dbg
  28.    call db0checkbp
  29.    if dbtrc=-7 then do
  30.  
  31.      if dbtcode='80H' then
  32.      call db0event 851 dbnext
  33.      Else call db0event 041
  34.    end
  35.  
  36.    call db1exit
  37.    if dberrorsw then Call ON ERROR; else Call OFF ERROR
  38.    drop dblist db1
  39.      if dbw2=''  then return 0
  40.    if dbg=dbgg then return 0
  41.    if dbjump=1 then signal value dbg
  42.  end
  43.  return 0; DB0CHECKBP:
  44.  dbno=dbg%42+1
  45.  dbn=wordpos(dbg,'D' dbtbl.dbno)
  46.  dbtype=word('D' dbtbl.dbno,dbn+1)
  47.  if (dbproc<>'')+(dbstep?)>0 then do                     /*F*/
  48.    if dbproc=0 then dbcallstack=delword(dbcallstack,1,1) /*F*/
  49.    else dbcallstack=dbproc delword(dbcallstack,5)        /*F*/
  50.    if dbstep? then do                                    /*F*/
  51.      if dblevel0? then parse value 0 1 0 1 with,         /*F*/
  52.      dbstep? dblogproc dblevel0? dbbreak?                /*F*/
  53.      if dbnest=0 & dblogproc=0 then dblevel0?=1          /*F*/
  54.      else do                                             /*F*/
  55.        if dbnest=1        then dblogproc=0               /*F*/
  56.        if dbproc=0        then dbnest=dbnest-1           /*F*/
  57.        else if dbproc<>'' then dbnest=dbnest+1           /*F*/
  58.        if dbnest<=0       then dbnest=0                  /*F*/
  59.        if dbnest>0        then dbbreak?=0                /*F*/
  60.      end                                                 /*F*/
  61.    end                                                   /*F*/
  62.    dbproc=''                                             /*F*/
  63.  
  64.  end                                                     /*F*/
  65.  if dbwatchsw then if db2watch() then return db0dobp(030 dblist)
  66.  if db2count()=0 then return db0dobp()
  67.  if dbtrc=-7 then return -7 dbtrap
  68.  select
  69.    when dbtype='S' then do
  70.      call db3back dbg+1,dbg+1,'S'
  71.      dbtrc=dbw2
  72.      if dbtrc=-7 then return -7 dbtrap
  73.  
  74.      dbg=dbw2
  75.      dbskip?=1;end
  76.    When (dbbreak?)+(dbresume=dbg)>0 then do
  77.      dbresume=0
  78.  
  79.      return db0dobp(); end
  80.    when dbtype='E' then do
  81.      dbskip?=1
  82.      ':'dbg; end
  83.    When dbtype='D' then do
  84.      if dbtracesw then call db1trace
  85.      dbskip?=0;end
  86.    Otherwise
  87.    If dbbreak? then nop /* do later */
  88.    call db0dobp 110 dbg
  89.  end
  90.  if dbtrc=-7 then return -7 dbtrap
  91.  
  92.  return 0; DB0DOBP:  arg dbno dbmsg2    /*!1*/
  93.  if dbtracesw then call db1trace
  94.  Parse Value 0 0 With dbcount dbskip?
  95.  if dbno<>'' then dbmsg=dbmsg rdbmsg(dbno dbmsg2) /*!1*/
  96.  do forever
  97.    call db1prompt dbmsg
  98.    if dbtrc=-7 then if dbtcode<>'80H' then call db0event 043  /*!1*/
  99.    else leave
  100.  
  101.  end
  102.  
  103.  return 0; DB0EVENT:   parse arg dbmsgno dbrest
  104.  parse value dbtrap with dbint dbxme dbsigl dbtcode dbtrap
  105.  if dbinside? then dbmsg=dbmsg dbstr
  106.  if dbcallstack<>'' then dbtrap=dbtrap rdbmsg(842 dbcallstack)
  107.  dbmsg=dbmsg dbtrtn dbtrap
  108.  Parse Value 0 With dbtrc dbtrapp dbtrap
  109.  call db1prompt dbmsg rdbmsg(dbmsgno dbrest)
  110.  
  111.  return 0; db1ENTRY: arg dbp
  112.  Parse Value dbp dbp With dbg dbgg
  113.  if dbtallysw then db.dbg=db.dbg+1                       /*F*/
  114.  signal off novalue
  115.  parse value dbusigl'!'rc'!'result with dbuvarr
  116.  dbce '/FN/FT/MSGM/SCR/LSCR'
  117.  parse value fname.1''dbs''ftype.1 with dbfileid
  118.  if dbsys='OS2' then do                                 /*O*/
  119.    dbdr=left(syssearchpath( 'path', '\nul'),2)          /*O*/
  120.    address cmd dbdrs    /* doesn't work */              /*O*/
  121.    dbdir=directory(dbdirs)                              /*O*/
  122.  end                                                    /*O*/
  123.  signal on novalue
  124.  dbcs 'SCR 1'
  125.  dbxx dbpath''dbsession '(PROF RDPROFIL'
  126.  dbc  'BOT'
  127.  dbcs 'SCR 2'
  128.  dbso 'TABCMDF'
  129.  dbxx dbpath''dbdfile   '(PROF RDPROFIL'
  130.  dbcs 'VE 6' dblscr
  131.  
  132.  return 0; db1EXIT:
  133.  call db2restore
  134.  dbxx dbpath''dbfileid '(prof rdprofil'
  135.  dbwait=dbsavew
  136.  if dbtype='D' | dbtype='B' then dblast=dbg
  137.  drop dbuvarr
  138.  if dbsys='OS2' then do                                  /*O*/
  139.     address cmd dbdr                                     /*O*/
  140.     call directory dbdirs; end                           /*O*/
  141.  
  142.  return 0; db1PROMPT: parse arg dbmsg
  143.  Do forever
  144.    call db1msgs
  145.    if dbread?=1 then do
  146.  
  147.      parse value     rdbinit('/IN' dbinclude) with dbtrc dbtrap
  148.      dbstr=dbtrap
  149.      if dbtrc=-7 then return -7 dbtrap
  150.      if dbprgm='DEMO' then interpret rddemo(dbstr)
  151.    end
  152.    else do
  153.  
  154.      parse value     rdbui('!' dbfullsw dberrorsw dblogsw dbtracesw,
  155.      dbtallysw dbwatchsw dblimit dbwait dbwatch) with dbstr
  156.      parse value dbstr with dbtrc dbtrap
  157.      if dbtrc='ABORT' then do; 'EMSG ABORTING'; exit; end
  158.    end
  159.    if dbtrc=-7 then return -7 dbtrap
  160.    parse var dbstr dbw1 dbw2 dbrem
  161.    if dbw1='NOMSG' then do while dbw1='NOMSG'
  162.      parse var dbstr . . dbstr
  163.      parse var dbstr dbw1 dbw2 dbrem; end
  164.  
  165.    if left(dbw1,1)='*' then iterate
  166.  
  167.  
  168.  
  169.    dbcurfile=db8thisfile();
  170.    if dbcurfile=dbpath''dbdfile then dbinside?=1; else dbinside?=0
  171.  
  172.  
  173.  
  174.  
  175.    if left(dbw1,1)='=' then dbstr=dbm.dbq                /*F*/
  176.  
  177.  
  178.    if left(dbw1,1)='&' then                              /*F*/
  179.    Parse Value dbstr'!'substr(dbstr,2) With dbcmsg'!'dbstr /*F*/
  180.  
  181.    parse upper var dbstr dbw1 dbw2 dbrem
  182.  
  183.  
  184.    if dbm.dbq<>dbstr then do                             /*F*/
  185.      Parse Value dbq+1 dbq-11 With dbq dbqlast           /*F*/
  186.      if dbq>10 then drop dbm.dbqlast                     /*F*/
  187.      dbm.dbq=dbstr;end                                   /*F*/
  188.    if dblogsw then   call  db3log '**' dbstr
  189.    if dbtrc=-7 then return -7 dbtrap
  190.    trace value dbt.dbgt
  191.    if length(dbw1)=1 then call db1testor
  192.    else do
  193.      parse value     rdbcmds(dbw1 1 dbfullsw dbpath) with dbtrc dbtrap
  194.      if dbtrc=-7 then return -7 dbtrap
  195.      Parse Value dbtrc dbtrap With dbn dbcmdstr
  196.      select
  197.        When dbn=1 then do
  198.          dbtrtn=dbcmdstr 'rDEBUG command'
  199.  
  200.          interpret dbcmdstr
  201.        end
  202.        When dbn=2 then do
  203.  
  204.          if dbinside? then do
  205.            dbtrtn= dbcmdstr 'restricted rDEBUG command'
  206.  
  207.            interpret dbcmdstr
  208.          end
  209.  
  210.          else dbmsg=dbmsg rdbmsg(115 dbdfile, 'press F4')
  211.        end
  212.        When dbn=3 then do
  213.          call db8shield "interpret dbstr"
  214.        end
  215.        otherwise call db1testor
  216.      end
  217.    end
  218.    if dbw1=1 then leave
  219.    if dbtrc=-7 then return -7 dbtrap;
  220.  end
  221.  call db1msgs
  222.  if dbtrc=-7 then return -7 dbtrap;
  223.  drop dbw1 dbrem dbcmdstr
  224.  
  225.  return 0; db1MSGS:
  226.  if dbcmsg<>''then do
  227.    if length(dbcmsg)>dblscr-5&dbmsg=''then dbmsg=dbcmsg
  228.    else do
  229.      call db3log '*' strip(dbcmsg)
  230.      dbc 'CMSG *' dbstr; end
  231.  end
  232.  if dbmsg<>''then do
  233.    call db3log '*' strip(dbmsg); end
  234.  parse value '' with dbmsg dbcmsg
  235.  
  236.  return 0;   db1TESTOR:
  237.  dbi=pos('=',dbstr)
  238.  if dbi>1 then do
  239.    parse value substr(dbstr,1,dbi-1) with dbw1 dbw2 .
  240.    if dbw1<>'' & dbw2='' then do
  241.      dbtrtn= dbstr 'assignment statement'
  242.  
  243.      interpret dbstr
  244.    end
  245.    else do
  246.      dbtrtn=dbstr 'xedit instruction'
  247.  
  248.      interpret 'dbstr'
  249.    end
  250.  end
  251.  else call db8shield "interpret 'dbstr'"
  252.  dbw1=''
  253.  
  254.  return 0;   db1TRACE:
  255.  if dbskip?=0 & dblogproc=1 & dbresume=0 then do
  256.    if dblogsw&dblast>1 then do
  257.      dbtrace=substr(sourceline(dblast),dbuc)
  258.      call db3log '***' dbtrace
  259.      if dbtrc=-7 then return -7 dbtrap
  260.      call db3log dbtrace
  261.      drop dbtrace; end
  262.  end
  263.  ':'dbg 'REFRESH'
  264.  
  265.  return 0;   DB2COUNT:
  266.  dbcount=dbcount+1                                       /*F*/
  267.  if dbcount>=dblimit then do                             /*F*/
  268.    dbcount=0
  269.    if dblimit<>1 then dbmsg=dbmsg rdbmsg(020 dblimit);end /*F*/
  270.  return dbcount
  271.  
  272.  db2WATCH:
  273.  Parse Value dbwatch '!' With dbws'!'dblist
  274.  signal off novalue
  275.  do while dbws<>''
  276.    parse var dbws dbw dbws
  277.    if left(dbw,1)='(' then do
  278.      interpret "db1=" dbw
  279.      if db1=1 then dblist=dblist dbw; end
  280.    else do
  281.      db1=value(dbw)
  282.      if (db1<>dbprev.dbw)+(left(dbw2,2)='WA')>0 then
  283.      Parse Value db1'!!!'dblist dbw'='value(dbw)';' With dbprev.dbw'!!!'dblist
  284.    end
  285.  end
  286.  signal on novalue
  287.  dbrc=(dblist<>'')
  288.  return dbrc
  289.  
  290.  db2RESTORE:
  291.  parse value dbuvarr with sigl'!'rc'!'result
  292.  
  293.  return 0;  db3BACK:
  294.  parse arg dbl, dbrange, dbtype  , dbprompt
  295.  if dbl='' then dbl=dbg
  296.  dblabel=1
  297.  select
  298.    when dbtype  ='S' then do
  299.      do dbl=dbl to dbrange until dblabel
  300.        dblabel=(substr(sourceline(dbl),dbuc-2,1)=':')
  301.      end
  302.      if dbl>dbl then dbl=dbl-1
  303.    end
  304.    when (dbtype='G')+ (dbtype='P')>0
  305.    then dblabel=(substr(sourceline(dbl),dbuc-2,1)=':')
  306.    otherwise dblabel=(substr(sourceline(dbl),dbuc-2,1)=':')
  307.  end
  308.  if datatype('0'dbl,'w')=0&dbl>dbsize then do
  309.    dbmsg=dbmsg rdbmsg(305 dbl); return 0;end
  310.  if dblabel & left(sourceline(dbl),5)='Call ' then ':'dbl
  311.  else do
  312.    if (dbl=1)+(dbtype='P')>0 then ':'dbl
  313.    else do
  314.      if dbjump= '1' then dbmsg=dbmsg rdbmsg(310 dbl)
  315.  
  316.      else dbmsg=dbmsg rdbmsg(311 dbl)
  317.  
  318.      dbl=0
  319.      if dbprompt<>'NOP' then call db1prompt dbmsg
  320.    end
  321.  end
  322.  return dbl;
  323.  
  324.  
  325.  db3LOG:  parse arg dbss dbline
  326. if dbxme<>'' then dbxme=''
  327. dbce '/LSCR'
  328. if lscreen.3<13 then dbscr=1; else dbscr=2
  329. If dbscr=2 then dbso 'TABCMDB'
  330. dbcurfile1=db8thisfile();
  331. dbso 'TABCMDF'
  332. dbcurfile2=db8thisfile();
  333. dbso 'TABCMDB'
  334. dbcs 'SCR1'
  335. if dbcurfile1<>dbpath''dbsession then dbxx dbpath''dbsession '(PROF RDPROFIL'
  336. dbc 'BOT'
  337. do dbn=1 to 6 while dbline<>''
  338.   dbpos=pos(dbsep,' 'dbline)                 /*!1*/
  339.   if dbpos>0 then do
  340.     dbm = left(dbline,dbpos-2)
  341.     dbline = substr(dbline,dbpos+2); end     /*!1*/
  342.   else do; dbm=dbline; dbline=''; end
  343.   if dbss='*'
  344.   then dbm='*' right(dbg,3) dbm
  345.   else if dbss='***' then dbm='*' right(dblast,3) dbm
  346.   else if dbss='**'  then dbm='     ' dbm
  347.   else do
  348.     dbstr=db7pairs(' 'strip(dbss dbm,'T'))
  349.     call db2restore
  350.     dbstr=strip(dbstr)
  351.     dbstr="''"translate(dbstr,' ',dbtranslate)
  352.     call db8shield "interpret 'dbstr=' dbstr"
  353.     dbm=translate(db7pairs(dbstr),' ',dbtranslate)
  354.     if dbm='' then do
  355.       call db3logexit
  356.       return dbtrc dbtrap;end
  357.     if right(dbstr,1)=',' then dbstr=substr(dbstr,1,length(dbstr)-1)
  358.     dbm='*' right(dblast,3) dbm
  359.  
  360.   end
  361.  
  362.   if dbinside? then do
  363.     dbc 'INP' dbm
  364.     dbc 'PUT 1' dbpath''dbsession; end
  365.   else dbc 'MSG' dbm
  366. end
  367. call db3logexit
  368. if dbinside?=0 then dbfc?=1
  369. drop dbm db1 dbss dbline
  370.  
  371. return 0;   db3logexit:
  372. if dbcurfile1<>dbpath''dbsession then do
  373.   dbxx dbcurfile1 '(PROF RDPROFIL'
  374.   dbc 'MSG' rdbmsg(230); end
  375. else dbc 'BOT'
  376. dbcs 'SCR2'
  377. dbso 'TABCMDF'
  378. dbxx dbcurfile2 '(PROF RDPROFIL'
  379. If dbscr=1 then dbso 'TABCMDB'
  380.  
  381. return 0; db4PREFIX: Procedure expose dbg dbmsg dbce dbcs line.1,
  382. dbbreak? dbalt dbc dbuc dbupdate? dbtbl. dbdfile dbprof dbs dbenvir,
  383. dbme dbsize dbtrc dbtrap dbtrapp dbpath dbinside? dbcallstack dbtrigger dbfullsw dberrorsw dblogsw,
  384. dbtracesw dbtallysw dbwatchsw dblimit dbwait dbwatch
  385. arg dbopt . dbw2 dbrem
  386.  dbce '/LINE'
  387. if dbw2=-1 then do                                      /*F*/
  388.   Parse Value dbw2%42+1 line.1 With dbno dbw2           /*F*/
  389.   if wordpos(dbw2,dbtbl.dbno)>0 then dbopt='DEBUG'      /*F*/
  390.   else dbopt='BREAK';end                                /*F*/
  391. if dbw2=''then do
  392.  
  393.   dbw2=line.1; end
  394. else if dbw2=0 then do;
  395.   dbbreak?=(dbbreak?=0);
  396.   if dbbreak? then dbw1='active'; else dbw1='cancelled'
  397.   dbmsg=dbmsg rdbmsg(411 dbw1)
  398.   return 0;end
  399. dbmsg=dbmsg 'DBG410r' dbopt dbw2 dbrem
  400. dbstr=dbopt dbw2 dbrem
  401. if pos('-',dbw2 dbrem)>0 then dbstr=rdbmisc('/EXPAND' dbstr)
  402. call db42delete dbstr
  403. if dbtrc=-7 then return -7 dbtrap
  404. call db43setcall dbopt dbstr
  405. if dbtrc=-7 then return -7 dbtrap
  406. parse value     RDBPROF('/CTRL . 0' dbpath dbsize dbdfile'!'dbprof'!'dbuc'!',
  407. dbfullsw dberrorsw dblogsw dbtracesw dbtallysw dbwatchsw,
  408. dblimit dbwait dbwatch'!'dbstr) with dbtrc dbtrap
  409. if dbtrc=-7 then return -7 dbtrap
  410. dbmsg=dbmsg dbtrap
  411.  
  412. return 0;   db42DELETE:
  413. procedure expose dbtbl. dbtrigger dbme dbsize
  414. arg . dbw dbws
  415. do dbx=1 while dbw<>''
  416.   if datatype('0'dbw,'W')=0 then dbmsg=dbmsg rdbmsg(340 dbw)
  417.   else do
  418.     dbn=dbw%42+1
  419.     dbi=wordpos(dbw,dbtbl.dbn)
  420.     if dbi > 0 then dbtbl.dbn=delword(dbtbl.dbn,dbi,2); end
  421.   parse var dbws dbw dbws
  422. end
  423.  
  424. return 0;   db43SETCALL:
  425. procedure expose dbtrigger dbjump dbmsg dbupdate? dbtbl. dbalt,
  426. dbsize dbme dbcs dbce dbc dbuc dbsize dbtrigger dbjump,
  427. dbenvir dbtrc dbtrap dbtrapp
  428. arg dbopt . dbw dbws
  429. dbce '/LINEN'
  430. dbcs 'LINEN OFF'
  431. dbinvalid=''
  432. do dbx=1 while dbw<>''
  433.   if db3back(dbw,,'P','NOP')=0 then dbinvalid=dbinvalid dbw
  434.   else do
  435.     dbce '/CURL'
  436.     if substr(curline.3,dbuc-2,1)<>':' & dbopt='SKIP'
  437.     then dbinvalid=dbinvalid dbw
  438.     else do
  439.       if substr(curline.3,1,4)='Call' then do
  440.         dbc 'REP' overlay(left(dbopt,5),curline.3,6)
  441.         Parse Value dbalt+1 dbw%42+1 With dbalt dbno
  442.         if dbopt<>'DEBUG'&dbupdate?
  443.         then dbtbl.dbno=dbtbl.dbno dbw left(dbopt,1);end
  444.     end
  445.   end
  446.   parse var dbws dbw dbws
  447. end
  448. if dbinvalid<>''then dbmsg=dbmsg rdbmsg(520 dbinvalid)
  449. dbcs 'LINEN' linend.1
  450.  
  451. return 0; db7PAIRS:
  452. procedure expose dbsq dbdq dbtrigger dbsize dbme
  453. parse arg str
  454. do forever
  455.   Parse Value pos(dbsq,str) pos(dbdq,str) pos('/*',str),
  456.   With h i j
  457.   if h=0 then h=256
  458.   if i=0 then i=256
  459.   if j=0 then j=256
  460.   j=min(h,i,j)
  461.   if j=256 then leave
  462.   Parse Value 1 substr(str,j,1) With width delimiter
  463.   if delimiter='/' then Parse Value '*/' 2 With delimiter width
  464.   Parse Value substr(str,1,j-1)'!'substr(str,j+width),
  465.   With temp'!'str
  466.   j=pos(delimiter,str)
  467.   if j>0 then str=temp substr(str,j+width)
  468.   else do;str=temp;leave;end
  469. end
  470. return str
  471.  
  472. db8THISFILE:
  473. address value dbenvir
  474. dbce '/FILEID'
  475. return fileid.1
  476.  
  477.  db8SHIELD:  parse arg dbin
  478.  signal off error
  479.  signal off syntax
  480.  signal off novalue
  481.  interpret dbin
  482.  signal on error
  483.  signal on syntax
  484.  signal on novalue
  485.  dbtrtn=''
  486.  
  487. return 0; ARG:  procedure expose dbparms
  488. arg dbn
  489. if datatype('0'dbn,'N') then
  490. dbn=word(dbparms,dbn)
  491. else dbn=''
  492.  
  493. return dbn;   DBI:
  494. Signal ON  ERROR;   Signal On  Failure; Signal ON  HALT
  495. Signal ON  Novalue; Signal On Notready; Signal ON  SYNTAX
  496. call db9init
  497.  parse value 1       with dcall
  498. call   ON  ERROR;   Call   On  Failure; CALL   ON  HALT
  499. /*!1Signal OFF Novalue; call   On Notready; Signal ON  SYNTAX*/
  500. Signal ON  Novalue; call   On Notready; Signal ON  SYNTAX
  501. if dbtrc=-7 then do
  502.   call db0event 042
  503.   dbc 'EMSG ABORTING'; exit; end
  504. address value dbdefenv
  505. drop dbdefenv dbvars dbtemp
  506. do forever
  507.   call db dbparms
  508.   dbbreak?=1
  509.   dbmsg=dbmsg rdbmsg(800)
  510.   dbcallstack=''
  511.   call debug 1, dbusigl
  512.   dbbreak?=0
  513. end
  514.  
  515. return 0; db9INIT:
  516. parse value 0 1 0 0 1 with dbbreak? dbinside? dbstep? dbnest dblogproc
  517. parse value 0 0 0 1 with dbfc? dbrestart? dbupdate? dbsyntax?
  518. parse value 1 0 'o ?r' with dbjump dbgt dbt.0 dbt.1
  519. parse value 0 0 0 50 0 0 with dblevel0? dbskip? dbq dblimit dbalt dblast
  520. parse value 0 0 'rc result 1' with dbusigl dbtrigger rc result sigl
  521. parse value 0 "'" '"' 0 0 with dbresume dbsq dbdq dbqlast db.
  522. Parse Value '' With dbprev. dbw2 dbmsg dbcmsg dbtbl. dbcallstack dbproc dbm.
  523. Parse Value '' With dbtrc dbtrapp dbtrtn dbwatch dbxme dbtcode dbstr
  524. dbtranslate='*,/+-%()=><:;&\'
  525. Parse Value 'COMMAND SET!COMMAND X!COMMAND EXT' With dbcs'!'dbxx'!'dbce
  526. Parse Value 'COMMAND!COMMAND SOS' With dbc'!'dbso
  527. dbsep='~'                     /*C*/
  528. dbsep=' '  /*!1 ascii 255 */  /*NC*/
  529. Parse Value rdbvars() with dbtrc dbtrap
  530. if dbtrc=-7 then return -7 dbtrap
  531. interpret dbtrc dbtrap
  532. dbme=dbdfile
  533. dbce '/OPSYS'
  534. dbsys=opsys.1
  535. /*if dbsys='OS2' then do         drop                   /*O*/
  536.   dbdrs=left(syssearchpath( 'path', '\nul'),2)          /*O*/
  537.   dbdirs=directory(dbdirs); end                         /*O*/*/
  538. dbline=8
  539. dbxx dbpath''dbprof '(PROF RDPROFIL'
  540. Signal OFF Error
  541. ':'dbline
  542. do dbx=1 to 25 until rc<>0
  543.   dbce '/CURL'
  544.   parse var curline.3 dbn dbrem
  545.   parse upper var dbn dbn
  546.   if datatype(dbn,'w') then dbtbl.dbn=strip(dbrem,'t')
  547.   else if dbn='WATCH' then dbwatch=dbrem
  548.   '+1'
  549. end dbx
  550. 'QQ'
  551. Signal ON Error
  552. parse value     rdbinit('/FI D' dbpath dbsize'!'dblogsw'!'dbuc'!'dbtest?,
  553. '!'dbsession'!'dbdfile'!'dbvars) with dbtrc dbtrap
  554. if dbtrc=-7 then return -7 dbtrap
  555. dbce '/LSCR'
  556. dblscr=lscreen.2
  557. parse value      rdbcmds('DB9PREFIX 5' dbfullsw dbpath) with dbtrc dbtrap
  558. if dbtrc=-7 then return -7 dbtrap
  559. interpret dbtrap
  560. call db2watch
  561. if dbtrc=-7 then return -7 dbtrap
  562. parse value dbwait 1 0 with dbsavew dbupdate? dbalt dbw2 dbtemp
  563. dbmsg=rdbmsg(112 date() time())
  564. dbc 'sos alarm'
  565. ':1 X' dbpath''dbinvoke  '(PROF RDPROFIL'
  566. return 0
  567.  
  568. ERROR:    return db9trap(sigl '80E' sourceline(sigl)'~')
  569. FAILURE:  return db9trap(sigl '80F' sourceline(sigl)'~')
  570. HALT:     return db9trap(sigl '80H')
  571. NOTREADY: return db9trap(sigl '80R' sourceline(sigl)'~')
  572. NOVALUE:
  573. call db9trap sigl '80V'
  574. call debug dbg
  575. if dbg>dbsize then return -7 dbtrap
  576. signal value dbg
  577. SYNTAX:
  578. call db9trap sigl '80S' errortext(rc)'~'sourceline(sigl)'~'
  579. call debug dbg
  580. if dbg>dbsize then return -7 dbtrap
  581. signal value dbg
  582. db9TRAP:
  583. if dbtrc=-7 then dbtrapp=dbtrap
  584. parse arg dbsigl dbtcode dbtrest
  585. dbtrap = dbtrapp 1 dbme dbsigl dbtcode rdbmsg(dbtcode dbme dbsigl) dbtrest
  586. dbtrc=-7
  587. sigl=dbsigl
  588. if dbsigl<dbsize then call debug 1
  589. return -7 dbtrap
  590.