zOs/REXX/FMT

/* copy fmt    begin **************************************************/
/*--- format the first arg by the format in the second ---------------*/
fmt: procedure
parse arg v, f 2 l
    if abbrev('-', f) then
        return v
    else if f == 'l' then
        return left(v, l)
    else if f == 'r' then
        return right(v, l)
    else if f == 'f' then do
        parse value l'.0.0.' with b '.' a '.' e '.'
        return format(v, b, a, e, 0)
        end
    else if f == 'e' then do
        parse var l b '.' a '.' e '.'
        if b == '' then b = 2
        if a == '' then a = 2
        if e == '' then e = 2
        res = format(v, b, a, e, 0)
        y = length(res)-e-1
        if substr(res, y) = '' then
            return left(res, y-1)left('E', e+1, 0)
        else if substr(res, y+1, 1) == '+' then
            return left(res, y)substr(res, y+2)
        else if substr(res, y+2, 1) == '0' then
            return left(res, y+1)substr(res, y+3)
        else
            call err 'formatoverflow' f || l 'for' v '-->' res
        end
     else if f = 's' then
        if l == '' then
            return strip(v, 't')
        else
            return strip(v, l)
    else if f == 'w' then do
        parse var l st ',' le
        return substr(v, st, le)
        end
    else
        call err 'bad format' f l 'for' v
endProcedure fmt

/*--- format special (title, null Value also for numbers) ------------*/
fmtS: procedure expose m.
parse arg v, ty 2 l
    if ty == 'f' then do
        if \ dataType(v, 'n') then do
            parse value l'.0.0.' with b '.' a '.' e '.'
            return right(v, b + a + (a \== 0) + e + 2 * (e > 0))
            end
        end
    else if ty == 'e' then do
        if \ dataType(v, 'n') then do
            parse var l b '.' a '.' e '.'
            if b == '' then b = 2
            if a == '' then a = 2
            if e == '' then e = 2
            return right(v, b + a + (a \== 0) + e + (e > 0))
            end
        end
    return fmt(v,  ty || l)
endProcedure fmtS
fmtTime: procedure expose m.
parse arg s, signed
    return fmtUnits(s, 't', signed==1)
endProcedure fmtTime

fmtDec: procedure expose m.
parse arg s, signed
    return fmtUnits(s, 'd', signed==1)
endProcedure fmtDec

fmtUnits: procedure expose m.
parse arg s, scale, signed
    if s >= 0 then
        res = fmtUnitsNN(s, scale, wi)
    else
        res = '-'fmtUnitsNN(abs(s), scale, wi)
    len = m.fmt.units.scale.f.length + signed
    if length(res) <= len then
       return right(res, len)
    if \ abbrev(res, '-') then
        return right(right(res, 1), len, '+')
    if length(res) = len+1 & datatype(right(res, 1), 'n') then
        return left(res, len)
    return right(right(res, 1), len, '-')
endProcedure fmtUnits

fmtUnitsNN: procedure expose m.
parse arg s, scale
    sf = 'FMT.UNITS.'scale'.F'
    sp = 'FMT.UNITS.'scale'.P'
    if m.sf \== 1 then do
        call fmtIni
        if m.sf \== 1 then
            call err 'fmtUnitsNN bad scale' scale
        end

    do q=3 to m.sp.0 while s >= m.sp.q
        end
    do forever
        qb = q-2
        qu = q-1
        r = format(s / m.sp.qb, ,0)
        if q > m.sf.0 then
            return r || substr(m.sf.units, qb, 1)
        if r < m.sf.q * m.sf.qu then
            return (r % m.sf.qu) || substr(m.sf.units, qu, 1) ,
                              || right(r //m.sf.qu, m.sf.width, 0)
            /* overflow because of rounding, thus 1u000: loop back */
        q = q + 1
        end
endProcedure fmtUnitsNN

fmtIni: procedure expose m.
    if m.fmt.ini == 1 then
        return
    m.fmt.ini = 1
    call fmtIniUnits 't', '?smhd', 0 100 60 60 24 100, 0.01, 2
    call fmtIniUnits 'd', '?.kMGTPE', 0 copies('1000 ',8), 0.001, 3
    return
endProcedure fmtIni

fmtIniUnits: procedure expose m.
parse arg sc, us, fact, prod, wi
    sf = 'FMT.UNITS.'sc'.F'
    sp = 'FMT.UNITS.'sc'.P'
    m.sf.0 = words(fact)
    if length(us) + 1 <> m.sf.0 then
        call err 'fmtIniUnits mismatch' us '<==>' fact
    m.sf.1 = word(fact, 1)
    m.sp.1 = prod
    do wx=2 to m.sf.0
        wx1 = wx-1
        m.sf.wx = word(fact, wx)
        m.sp.wx = m.sp.wx1 * m.sf.wx
        end
    m.sp.0 = m.sf.0
    m.sf.units = us
    m.sf.width = wi
    m.sf.length= 2 * wi + 1
    m.sf = 1
    return
endProcedure fmtIniUnits

/* copy fmt    end   **************************************************/