zOs/REXX.O08/ERR

/* copy err begin ******************************************************
    messages, errorhandling,help
***********************************************************************/
/* configure err -----------------------------------------------------*/
errReset: procedure expose m.
parse arg oo, ha
    if pos('I', translate(oo)) > 0 then
        call adrIsp 'control errors return'
    m.err.opt = translate(oo, 'h', 'H')
    if ha == '' then
        drop m.err.handler
    else
        m.err.handler = ha
    return
endSubroutine errReset

/*--- error routine: abend with message ------------------------------*/
err:
    parse arg ggTxt, ggOpt
    drop err handler opt
    if ggOpt == '' & symbol('m.err.handler') == 'VAR' then
        interpret m.err.handler
    call errSay ggTxt
    parse source . . ggS3 .                           /* current rexx */
    if ggOpt == '' | ggOpt == '*' then
        ggOpt = translate(value('m.err.opt'), 'ht', 'HT')
    if pos('h', ggOpt) > 0  then do
        say 'fatal error in' ggS3': divide by zero to show stackHistory'
        x = 1 / 0
        end
    say 'fatal error in' ggS3': exit(12)'
    exit errSetRc(12)
endSubroutine err

/*--- assert that the passed rexx expression evaluates to true -------*/
assert:
    interpret 'assertRes =' arg(1)
    if ^ assertRes then
        call err 'assert failed' arg(1)':' arg(2)
    return
endProcedure assert

/*--- say an errorMessage msg with pref pref
           split message in lines at '/n'
           say addition message in stem st ---------------------------*/
errSay: procedure expose m.
parse arg msg, st, pref
    parse source . . ggS3 .                           /* current rexx */
    if pref == 'e' | (pref == '' & st == '') then
        msg = 'fatal error:' msg
    else if pref == 'w' then
        msgf = 'warning:' msg
    else if pref == 0 then
        nop
    else if right(pref, 1) ^== ' ' then
        msg = pref':' msg
    else
        msg = pref || msg
    sx = 0
    bx = -1
    do lx=1 until bx >= length(msg)
        ex = pos('\n', msg, bx+2)
        if ex < 1 then
            ex = length(msg)+1
        if st == '' then do
            say substr(msg, bx+2, ex-bx-2)
            end
        else do
            sx = sx+1
            m.st.sx = substr(msg, bx+2, ex-bx-2)
            m.st.0 = sx
            end
        bx = ex
        end
    return
endProcedure errSay

/*--- abend with Message after displaying help -----------------------*/
errHelp: procedure expose m.
parse arg msg, op
    say 'fatal error:' msg
    call help
    call err msg, op
endProcedure errHelp

/*--- set rc for ispf: -------------------------------------------------
    if a cmd is run by ispStart, its RC is ignored,
         but ISPF passes the value of the shared varible 3IspfRc
         back as return code
----------------------------------------------------------------------*/
errSetRc: procedure expose m.
parse arg zIspfRc
    if sysVar('sysISPF') = 'ACTIVE' then do
        address ispExec vput 'zIspfRc' shared
        end
    return zIspfRc
endProcedure errSetRc

/*--- output a trace message if m.trace is set -----------------------*/
trc: procedure expose m.
parse arg msg
    if m.trace == 1 then
        say 'trc:' msg
    return
endProcedure trc

/*--- quote string txt using quoteChar qu ("""" ==> ") ---------------*/
quote: procedure expose m.
parse arg txt, qu
    if qu = '' then
        qu = '"'
    res = qu
    ix = 1
    do forever
        qx = pos(qu, txt, ix)
        if qx = 0 then
            return res || substr(txt, ix) || qu
        res = res || substr(txt, ix, qx-ix) || qu || qu
        ix = qx + length(qu)
        end
endProcedure quote

debug: procedure expose m.
parse arg msg
    if m.debug == 1 then
        say 'debug' msg
    return
endProcedure debug

/*--- return current time and cpu usage ------------------------------*/
timing: procedure expose m.
return time() time('E') sysvar('syscpu') /* sysvar('syssrv') */

/--- display the first comment block of the source as help -----------*/
help: procedure expose m.
    parse source . . s3 .
    say right(' help for rexx' s3, 79, '*')
    do lx=1 by 1
        if pos('/*', sourceLine(lx)) > 0 then
            leave
        else if lx > 10 then do
            say 'initial commentblock not found for help'
            return
            end
        end
    do lx=lx+1 by 1
        li = strip(sourceLine(lx), 't', ' ')
        if pos('*/', li) > 0 then
            leave
        say li
        end
    say right(' end help for rexx' s3, 79, '*')
    return 4
endProcedure help
/* copy err end   *****************************************************/