zOs/REXX.O13/CSI

/* copy csi begin    ***************************************************
     csi interface: see dfs managing catalogs chapt. 11
         returncode/reason see message IDC3009I
**********************************************************************/
/*--- specify dsn mask and fields to start a csi catalog search --------
      arguments:
          m       objectPointer
          dsnMask specifies the dsns with wildcards:
              %  1 character
              *  0 - n character in one level
              ** 0 - n levels
          fields a (space separated) list of field names -------------*/
csiOpen: procedure expose m.
parse arg m, dsnMask, fields
    m.m.fld.0 = words(fields)
    ffix = d2c(m.m.fld.0, 2)
    do x=1 to m.m.fld.0
        m.m.fld.x = translate(word(fields, x))
        ffix = ffix || left(m.m.fld.x, 8)
        end
    if dsnMask \== '' & pos('*', dsnMask) < 1 then
        dsnMask = dsnMask'.**'
    m.m.filt = left(dsnMask, 149) ,
             || left('Y', 3) ,        /* resume offset 149      */
             || ffix                  /* csiNumEn offset 152    */

    WORKLEN = 1024 * 64
    m.m.work = D2C(WORKLEN,4) || COPIES('00'X,WORKLEN-4)
    m.m.pos = workLen + 1
    return
endProcedure csiOpen

/*--- put the next dsn into m.o and m.o.* (for other fields)
      return 1 if next dsn exists 0 otherwise ------------------------*/
csiNext: procedure expose m.
parse arg m, o
    usedL = C2D(SUBSTR(m.m.work,9,4)) /* GET AMOUNT OF WORK AREA USED */
    px = m.m.pos
    do forever
        if px > usedL then do
            if substr(m.m.filt, 150, 1) \== 'Y' then do
                m.m.pos = px
                m.o = ''
                return 0
                end
            reason = left('', 4)
            ADDRESS LINKPGM 'IGGCSI00  reason m.'m'.filt  m.'m'.work'
            if rc == 0 & substr(reason, 3, 2) == '0000'x then
                nop
            else if rc == 4 & substr(reason, 3, 2) == '0464'x then
                say 'data set entry with error'
            else
                call err 'call csi returns' rc,
                             'rc' c2d(substr(reason, 4,1)),
                             'reason' c2d(substr(reason, 3,1)),
                             'module' substr(reason, 1,2)
            usedL = C2D(SUBSTR(m.m.work,9,4)) /* GET WORK AREA USED */
            numFD = C2D(SUBSTR(m.m.work,13,2)) /* no flds + 1 */
            if numFd <> m.m.fld.0 + 1 then
                call err 'csiNumFd' numFd 'not' m.m.fld.0 '+' 1
            px = 15
            iterate
            end
        eType =  substr(m.m.work, px+1, 1)
        m.o = strip(substr(m.m.work, px+2, 44), 't')
        flag = substr(m.m.work, px, 1)
        /* say 'eType' eType m.o 'flag' c2x(flag) */
        if eType == '0' then do
            if flag \== '00'x & flag \== '40'x then
                call err 'flag' c2x(flag) 'for catalog' m.o
            px = px + 50    /* length of catalog entry  */
            iterate
            end
        else do
            if \ abbrev(x2b(c2x(flag)), '101') then
                call err 'call csi entry flag' x2b(c2x(flag)),
                             'rc' c2d(substr(m.m.work, px+49,1)),
                             'reason' c2d(substr(m.m.work, px+48,1)),
                             'module' substr(m.m.work, px+46, 2),
                             'for entry' m.o,
                             'see qw IDC3009I'
            py = px + 46
            tl = c2d(substr(m.m.work, py, 2))
            pl = py + 4
            pf = py + m.m.fld.0 * 2 + 4
            do fx = 1 to m.m.fld.0
                fi = m.m.fld.fx
                fl = c2d(substr(m.m.work, pl, 2))
                m.o.fi = substr(m.m.work, pf, fl)
                if fi = 'MGMTCLAS' then
                    m.o.fi = substr(m.o.fi, 3, c2d(left(m.o.fi ,2)))
                else if wordPos(fi, 'COMUDSIZ NOBYTTRK') > 0 then
                    m.o.fi = utc2d(m.o.fi)
        /*      say fi '=??? <'m.o.fi'>' c2x(m.o.fi)  */
                pf = pf + fl
                pl = pl + 2
                end
            if py + tl <> pf then
                call err 'length mismatch for entry' m.o
            m.m.pos = pf
            return 1
            end
        end
endProcedure csiNext
/*--- if dsn is arcived return 'arcive'
      if dsn is tape return 'tape'
      otherwise return managment class ------------------------------*/
csiArcTape: procedure expose m.
parse arg vo, cl, dt, dsn
        if vo = '' then
            say err '||| no volume for dsn' dsn
        else if vo = 'ARCIVE' then
            res = 'arcive'
        else if cl <> '' then
            res = cl
        else if abbrev(vo, 'SHR') then
            res = 'SHR'
        else
            res = 'tape'
        if   res = 'arcive' then
            return res
      /*if   abbrev(res, 'ar') \= abbrev(dt, '00'x) , */
        if   abbrev(res, 'ta') \= abbrev(c2x(left(dt, 1)), '7') ,
           | (left(res, 1) >= 'A') \= abbrev(dt, '30'x) then
           say '||| mismatch cl' cl 'vo' vo 'dt' c2x(dt) 'dsn' dsn
        return res
endProcedure csiArcTape
/* copy csi end ******************************************************/