zOs/REXX.O13/O

/* copy o begin ******************************************************
    an object is register for a class in o2c
    a class has a list of parents in cParent
    a class has a methodTable cMet with lazy initialization
        if the parent is class OLazyMet, a methof found there is
             a method generator
        otherwise an existing method is simply copied
***********************************************************************/
oIni: procedure expose m.
    if m.o.ini == 1 then
        return
    m.o.ini = 1
    call mIni
    m.o.escW = ']'
    m.o.lazyGen = 'OLazyMetGen' /* lazy method generator */
    call oAddCla m.o.lazyGen
    return
endProcedure oIni

/*--- return whether cl is a currently defined class ----------------*/
oIsCla: procedure expose m.
parse arg cl
    return symbol('m.o.cParent.cl') == 'VAR'
endProcedure oIsCla

/*--- add class cl with the given parents ---------------------------*/
oAddCla: procedure expose m.
parse arg cl, parents
    if verifId(cl, '.') > 0 | pos('.', cl) <> lastPos('.', cl) then
        call err 'bad class name' cl 'in oAddCla('cl',' parents')'
    if oIsCla(cl) then
        call err 'duplicate class' cl 'in oAddCla('cl',' parents')'
    do px=1 to words(parents)
        if \ oIsCla(word(parents, px)) then
            call err word(parents, px) 'is no class' ,
                    'in oAddCla('cl',' parents')'
        end
    m.o.cParent.cl = parents
    return
endProcedure oAddCla

/*--- add to class cl method met ------------------------------------*/
oAddMet: procedure expose m.
parse arg cl, met, cont
    if \ oIsCla(cl) then
        call err 'undefined class' cl 'in oAddMet('cl',' met',' cont')'
    if symbol('m.o.cMet.cl.met') == 'VAR' then
       call err 'duplicate method' met 'in oAddMet('cl',' met',' cont')'
    m.o.cMet.cl.met = cont
    return
endProcedure oAddMet
/*--- create an an object of the class className
        and call it's new method ------------------------------------*/
oNew: procedure expose m.
parse arg cl, arg, arg2, arg3
    if symbol('m.o.cParent.cl') \== 'VAR' then
        cl = class4name(cl)
    interpret oClaMet(cl, 'new')
endProcedure oNew

/*--- return the class of object obj --------------------------------*/
objClass: procedure expose m.
parse arg m
    if symbol('m.o.o2c.m') == 'VAR' then
         return m.o.o2c.m
    else if abbrev(m, m.o.escW) then
         return m.class.classW
    else if arg() >= 2 then
        return arg(2)
    else
        return err('no class found for object' m)
endProcedure objClass

oKindOf: procedure expose m.
parse arg obj, sup
    cl = objClass(obj, '')
    if cl == '' then
        return 0
    return oClaInheritsOf(cl, sup)
endProcedure oKindOf

oClaInheritsOf: procedure expose m.
parse arg cl, sup    /* wkTst optimierung in classAdded */
    if symbol('m.o.cParent.cl') \== 'VAR' then
         cl = class4name(cl)
    if symbol('m.o.cParent.sup') \== 'VAR' then
         sup = class4name(sup)
    if cl == sup then
        return 1
    do sx=1 to words(m.o.cParent.cl)
        if oClaInheritsOf(word(m.o.cParent.cl, sx), sup) then
            return 1
        end
    return 0
endProcedure oClaInheritsOf
/*--- return the code of method me of object m
         set m to the address and ggClass to the class ---------------*/
objMet: procedure expose m. m ggClass
parse arg m, me
    if symbol('m.o.o2c.m') == 'VAR' then
         ggClass = m.o.o2c.m
    else if abbrev(m, m.o.escW) then
         ggClass = "w"
    else if arg() >= 3 then
        return arg(3)
    else
        return err('no class found for object' m)
    if symbol('m.o.cMet.ggClass.me') == 'VAR' then
       return m.o.cMet.ggClass.me
    code = oClaMet(ggClass, me, '---')
    if code \== '---' then
        return code
    else if arg() >= 3 then
         return arg(3)
    return err('no method' me 'in class' className(ggClass) ,
               'of object' m)
endProcedure objMet

oClaMet: procedure expose m.
parse arg cl, me
    if symbol('m.o.cMet.cl.me') == 'VAR' then
       return m.o.cMet.cl.me
    if \ oIsCla(cl) then do
        c2 = class4Name(cl, '')
        if c2 \== ''  & oIsCla(c2) then do
            cl = c2
            if symbol('m.o.cMet.cl.me') == 'VAR' then
                return m.o.cMet.cl.me
            end
        else do
            if arg() >= 3 then
                return arg(3)
            else
                return err('no class' cl 'in oClaMet('cl',' me')')
            end
        end
    code = oLazyMetGen(m.o.lazyGen, cl, me)
    do px = 1 to words(m.o.cParent.cl) while code == '---'
        code = oClaMet(word(m.o.cParent.cl, px), me, '---')
        end
    if code == '---' then do
        if arg() >= 3 then
            return arg(3)
        else
            return err('no met' me 'in class' cl)
        end
    m.o.cMet.cl.me = code
    return code
endProcedure oClaMet

oLazyMetGen: procedure expose m.
parse arg lg, cl, me
    if symbol('m.o.cMet.lg.me') \== 'VAR' then
        return '---'
    interpret m.o.cMet.lg.me
endProcedure oLazyMetGen

/*--- return the stem of fieldnames of object m ---------------------*/
oFlds: procedure expose m.
parse arg m
    return objMet(m, 'oFlds')
endProcedure oFlds

oPrint: procedur expose m.
parse arg m
    ff = oFlds(m)
    t = ''
    do fx=1 to m.ff.0
        f1 = m || m.ff.fx
        t = t',' substr(m.ff.fx, 2)'='m.f1
        end
    return m'='className(objClass(m))'('substr(t, 3)')'
endProcedure oPrint

/*--- return the contents of field f navigation along path ----*/
oGet: procedure expose m.
parse arg obj, path, clazz
    nullNew = 0
    ret = oAccPath(obj, path, clazz)
    if ret == 1 then
        ret = oAccStr(m, cl)
    if ret == 1 then
        return str
    return err(ret 'in oGet('obj',' path')')
endProcedure oGet

oAccStr: procedure expose m. str
parse arg m, cl
    if cl == m.class.classV then
        str = m.m
    else if m.cl.valueCl == '' then
        return 'no value @' m 'class' className(cl)
    else if m.m == '' then
        return 'null @' m 'class' className(cl)
    else if abbrev(m, m.o.escW) then
        str = substr(m ,2)
    else
        str = o2String(m.m)
    return 1
endProcedure oAccStr

oGetO: procedure expose m.
parse arg obj, path, opt, clazz
    nullNew = pos('n', opt) > 0
    ret = oAccPath(obj, path, clazz)
    if ret == 1 then
        ret = oAccO(m, cl, opt)
    if ret == 1 then
        return ref
    else
        return err(ret 'in oGetO('obj',' path')')
endProcedure oGetO

oAccO: procedure expose m. ref
parse arg m, cl, opt
    if cl == m.class.classV then do
        ref = s2o(m.m)
        end
    else if m.cl \== 'r' then do
        ref = m
        end
    else if m.m == '' then do
        if opt == '-b' then do
            m.m = jBuf()
            end
        else if opt == '-n' then do
            rsn = oRefSetNew(m, cl)
            if rsn \==1 then
               return rsn
            end
        ref = m.m
        end
    else if objClass(m.m, 0) \== 0 then do
        ref = m.m
        end
    else do
        return 'no class for' m.m '@' m 'class' cl
        end
    return 1
endProcedure oAccO

oPut: procedure expose m.
parse arg obj, path, str
    nullNew = 1
    res = oAccPath(obj, path)
    if res == 1 then
        res = ocPut(m, cl, str)
    if res == 1 then
        return str
    return err(res 'in oPut('obj',' path',' str')')
endProceudre oPut

ocPut: procedure expose m.
parse arg m, cl, str
    if m.cl.valueCl == m.class.classV then
        m.m = str
    else if m.cl.valueCl \== '' then
        m.m = s2o(str)
    else
        return 'no value @' m 'class' className(cl)
    return 1
endProcedure ocPut

oPutO: procedure expose m.
parse arg obj, path, ref
    nullNew = 1
    res = oAccPath(obj, path)
    if res == 1 then
        res = ocPutO(m, cl, ref)
    if res == 1 then
        return ref
    return err(ret 'in oPut('obj',' path',' ref')')
endProcedure oPutO

ocPutO: procedure expose m.
parse arg m, cl, ref
    if m.cl.valueCl == m.class.classV then
        m.m = o2string(ref)
    else if m.cl.valueCl \== '' then
        m.m = ref
    else if m.cl.stemCl \== '' then
        return 'implement put to stem'
    else
        return 'no value @' m 'class' className(cl)
    return 1
endProcedure ocPutO

oClear: procedure expose m.
parse arg m
    interpret objMet(m, 'oClear')
    return m
endProcedure oClear

oClaClear: procedure expose m.
parse arg cla, m
    interpret "drop cla;" oClaMet(cla, 'oClear')
    return m
endProcedure oClaClear

oAccPath: procedure expose m. m cl nullNew
parse arg m, pa, cl
    if cl == '' & m \== '' then do
        cl = objClass(m)
        end
    if pa == '' then
        return 1
    call oClaMet cl, 'oFlds'
    if abbrev(pa, m.class.cRef) ,
            | (\ m.cl.hasFlds & abbrev(pa, m.class.cNav)) then do
        if pa == m.class.cRef & m.cl.valueCl == m.class.classV then do
            cl = m.class.classV
            return 1
            end
        if (m.cl.valueCl == '' | m.cl.valueCl == m.class.classV) ,
              & m.cl \== 'r' then
            return 'no reference @' m 'class' cl
        if m.m = '' then do
            if \ nullNew then
                return 'null @' m 'class' className(cl)
            rsn = oRefSetNew(m, cl)
            if rsn \== 1 then
                return rsn
            end
        return oAccPath(m.m, substr(pa, 2))
        end
    if pos(left(pa, 1), m.class.cPath) > 0 then
        return oAccPath(m, substr(pa, 2), cl)
    px = verify(pa, m.class.cPath, 'm')
    if px < 1 then
        px = length(pa)+1
    fn = left(pa, px-1)
    pa = substr(pa, px)
    if symbol('m.cl.f2c.fn') == 'VAR' then
        return oAccPath(m'.'fn, pa, m.cl.f2c.fn)
    if m.cl.stemCl=='' | fn=='' | verify(fn, '0123456789','n')>0 then
        return 'no field' fn '@' m 'class' className(cl)
    if fn == 0 then
        return oAccPath(m'.0', pa, m.class.classV)
    if abbrev(fn, 0) | verify(m.m.0, '0123456789', 'n') > 0,
            | fn > m.m.0 then
        return 'bad stem index' fn'>'m.m.0 '@' m 'class' className(cl)
    return oAccPath(m'.'fn, pa, m.cl.stemCl)
endProcedure oAccPath

oRefSetNew: procedure expose m.
parse arg m, cl
    cr = m.cl.valueCl
    if m.cr.class = '' then
        return 'no class for null @' m 'class' className(cl)
    if m.cr.class = m.class.classW then
        m.m = o2s()
    else if m.cr \== 'r' then
        return 'class' className(cl) 'not ref'
    else
        m.m = oNew(m.cr.class)
    return 1
endProcedure oRefSetNew


/*--- mutate object m to the class cl -------------------------------*/
oMutate: procedure expose m.
parse arg m, cl
    m.o.o2c.m = cl
    return m
endProcedure oMutate

/*--- mutate object m to the class named name -----------------------*/
oMutatName: procedure expose m.
parse arg m, nm
    m.o.o2c.m = class4Name(nm)
    return m
endProcedure oMutatName

/*--- copy object m of class cl to t --------------------------------*/
oClaCopy: procedure expose m.
parse arg cl, m, t
    interpret "drop cl;" oClaMet(cl, 'oCopy')
endProcedure oClaCopy

/*--- copy object m to t / create a new object if t=='' -------------*/
oCopy: procedure expose m.
parse arg m, t
    interpret objMet(m, 'oCopy')
endProcedure oCopy

/*--- return a new instance of a subclass of Run
        with code code in method oRun -------------------------------*/
oRunner: procedure expose m.
    if arg() >= 1 then
           r = oNew(classNew('n* ORun u ORun, m oRun' arg(1)))
    else
           r = oNew(classNew('n| ORun u ORun'))
    return r
endProcedure oRunner

/*--- set code for runner -------------------------------------------*/
oRunnerCode: procedure expose m.
parse arg r, code
    call classSetMet objClass(r), 'oRun', code
    return r
endProcedure oRunnerCode

/*--- run method oRun of object m -----------------------------------*/
oRun: procedure expose m.
parse arg m, arg, arg2, arg3
    interpret objMet(m, 'oRun')
    return
endProcedure oRun

/*--- run method oRun and return output in new JBuf ------------------*/
oRun2File: procedure expose m.
parse arg rn
    b = jBuf()
    call pipe '+F' , b
    call oRun rn
    call pipe '-'
    return b
endProcedure oRun2File

/*--- cast the object to a file -------------------------------------*/
o2File: procedure expose m.
parse arg m
    interpret objMet(m, 'o2File')
    call err 'o2file did not return'
endProcedure o2File

/*--- cast the object to a String -----------------------------------*/
o2String: procedure expose m.
parse arg m, fmt
    if opt == '' then
        opt = '-b '
    interpret objMet(m, 'o2String')
    return err('o2String did not return')
endProcedure o2String

/*--- return true if object is kind of String------------------------*/
oStrOrObj: procedure expose m. ggStr ggObj ggCla
parse arg ggObj, def
    if ggObj == '' then
        ggObj = def
    ggCla = objClass(ggObj, '')

    if ggCla == '' then do
        ggStr = ggObj
        ggObj = ''
        return 1
        end
    else if wordPos(ggCla, m.class.classV m.class.classW) > 0 then do
        ggStr = o2String(ggObj)
        ggObj = ''
        return 1
        end
    else do
        ggStr = ''
        return 0
        end
endProcedure oStrOrObj

/*--- return true if object is kind of String ----- ???? -------------*/
oStrOrFile: procedure expose m. ggStr ggObj ggCla
parse arg m, def
    if oStrOrObj(m, def) then
        return 1
    ggObj = o2File(ggObj)
    return 0
endProcedure oStrOrFile

/*--- return a short string representation of an object -------------*/
o2Text: procedure expose m.
parse arg m, maxL
    if m == '' then
        return '@ null object'
    if maxL == '' then
        maxL = 80
    cl = objClass(m, '?')
    if cl = m.class.classV then
        l = m.m
    else if cl == m.class.classW then
        l = substr(m, 2)
    else if cl == '?' then
        l = '@'m 'class=???'
    else do
        l = '@'m 'class='className(cl)
        ff = oFlds(m)
        do fx=1 to m.ff.0 while length(l) < maxL + 3
            if m.ff.fx == '' then
                 l = l', .='m.m
            else do
                 f1 = substr(m.ff.fx, 2)
                 l = l',' f1'='m.m.f1
                 end
            end
        end
    if length(l) <= maxL then
        return l
    return left(l, maxL-3)'...'
endProcedure o2Text

/*--- cast a String to an object -----------------------------------*/
s2o: procedure expose m.
parse arg str
    return m.o.escW || str
    return r
endProcedure s2o

oIfStr: procedure expose m.
parse arg m
    if length(m) > 200 then
        return m
    cl = objClass(m, '')
    if cl = '' then
        return m
    else if cl = m.class.classV then
        return = m.m
    else if cl == m.class.classW then
        return = substr(m, 2)
    else if arg() >= 2 then
        return arg(2)
    else
        call err m 'of class' className(cl) 'not kind of string'
endProcedure oIfStr

/* copy o end *******************************************************/