ftp.barnyard.co.uk/2015.02.ftp.barnyard.co.uk.tar/ftp.barnyard.co.uk/cpm/walnut-creek-CDROM/CPM/BDOS/DOSPLSOR.ARK/FDATE.MAC

Text File | 1986-10-29 | 14KB | 740 lines

title    'FDATE list file dates'
;
ver    equ    10
cr    equ    0dh
lf    equ    0ah
tab    equ    09h
;
; CPM/DOS+ syscall values
@cin    equ    1
@cout    equ    2
@csta    equ    11
@seldk    equ    14
@srch1    equ    17
@srchn    equ    18
@curdk    equ    25
@stdma    equ    26
@usrcd    equ    32
;
; CPM/DOS+ definitions
reboot    equ    0
sysfnc    equ    reboot+5;    connector to BDOS system
defdma    equ    reboot+080h
;
; UPPER case in following line for M80. SLRMAC does not need the file.
INCLUDE    Z80.LIB
;
;    --------- Start    ----------
;
    jmp    begin
;
maxusr:    db    31
;
; Upshift (a) if lower case alpha.
; a,f
upshft:    cpi    'a'
    rc
    cpi    'z'+1
    rnc
    ani    05fh
    ret
;
; Check (a) valid digit, carry if not
; f
qnum:    cpi    '0'
    rc
    cpi    '9'+1
    cmc
    ret
;
; crlf to console
; a,f
crlf:    mvi    a,cr
    call    couta
    mvi    a,lf
;    "    "
; console output from (a)
; a,f
couta:    push    d
    mov    e,a
    mvi    a,@cout
    call    bdos
    pop    d
    ret
;
; Numeric 1..99 to console.  Convert to Ascii, no zero suppress
; a,f
putnum:    push    b
    mvi    c,'0'-1
pn1:    inr    c
    adi    -10
    jrc    pn1
    adi    10
    push    psw
    mov    a,c
    call    couta
    pop    psw
    pop    b
    adi    '0'
    jr    couta
;
; Test for any console character ready. If so purge it and
; return nz flag.  Else return z flag.  Nulls absorbed
; a,f
qbreak:    mvi    a,@csta
    call    bdos
    rz
    mvi    a,@cin
    jr    bdos
;
; search next on (de)^. Z flag for failure, exit (a) incremented
; a,f
srchn:    mvi    a,@srchn
;    "    "
; execute functions, Z flag for 0ffh, increment return value
; a,f
sfncr:    call    bdos
    inr    a
    ret
;
; search for file fcbdrv. Z flag for failure, exit (a) incremented.
; a,f,d,e
ffind:    lxi    d,fcbdrv
    mvi    a,@srch1
    jr    sfncr
;
; Find current logged disk
qdisk:    mvi    a,@curdk
    jr    bdos
;
; Set user to absolute value in fcbusr and select on BDOS.
; Do not modify or select drive. Leave drv/usr in bc
; Update fcbusr to absolute value
; a,f,b,c,e
setusr:    lbcd    fcbusr;        c := user, b := drive
    mov    a,c
    ora    a
    cm    quser;        default, get current user
    mov    c,a;        now an absolute value
    sbcd    fcbusr
;    "    "
; set user to a
; a,f,e
susera:    mov    e,a
    jr    suser
;
; find current user code
; a,f,e
quser:    mvi    e,0ffh
;    "    "
; set user (e)
; a,f
suser:    mvi    a,@usrcd
;    "    "
; execute bdos call, return (a), set flags. Preserve other registers
; This is the sole connection to the outside world.
; a,f
bdos:    push    h
    push    d
    push    b
    pushix
    mov    c,a
    call    sysfnc
    ora    a;        set flags on return value
    popix
    pop    b
    pop    d
    pop    h
    ret
;
; set drive/user from fcbusr/fcbdrv
setdu:    call    setusr;        and b := drv, c := usr
    mov    a,b
    dcr    a
    cm    qdisk;        get default disk
    mov    b,a
    inr    b
    sbcd    fcbusr;        jam id
;    "    "
; select drive (a). DOS handles redundancies.
; a,f,e
seldka:    ani    0fh
    mov    e,a
    mvi    a,@seldk
    jr    bdos
;
; Parse the next field from the command line (IX^) into fcbdrv. Any
; drive/user specifications are recorded in fcbdrv and fcbusr
; (which default to 0 and -1 respectively).  name and type are parsed
; into fname and ftype, blank padded, with any '*'s expanded into
; '?'s, and the fields are blank padded.  At exit IX points to the
; field terminating delimiter char and lastwd points to the 1st char.
; a contains a count of '?' characters in fname & ftype fields, with
; flags set on it.  Illegal chars. cause abort.
; a,f,b,c,d,e,h,l,ix
parse:    xra    a
;    "    "
; Entry to parse 2nd drive spec. for xcom, when a = 010h
parsef:    lxi    h,fcbusr
    call    index;        select fcb or alternate fcb
    call    skipbk;        skip any leading blanks
    sixd    lastwd;        save marker for errors
    call    getdu;        c := user, b := drv
    mov    m,c;        set fcbusr
    inx    h
    mov    m,b;        set fcbdrv, set up for ldfld
    call    lastch
    cpi    ':'
    cz    nextch;        Absorb any du terminating ':'
    mvi    b,8
    push    h
    call    ldfld;        fill the name field
    call    lastch
    cpi    '.'
    cz    nextch;        Absorb any name terminating '.'
    mvi    b,3;         (else terminator blank fills)
    call    ldfld;        fill the type field
    mvi    b,3
parse1:    inx    h
    mvi    m,0
    djnz    parse1;        zero ex, s2, s1 fields
    lxi    b,11 shl 8;    b := 11, c := 0
    pop    h
    mvi    a,'?'
parse2:    inx    h
    cmp    m
    jrnz    parse3
    inr    c
parse3:    djnz    parse2;        count the '?'s in fname/ftype
    mov    a,c
    ora    a;        z flag for no wild cards
    ret
;
; load up to (b) chars from (ix)^ up to (hl)^ up.
; skip to delimiter.  Implement any wild cards on "*"
; blank fill if less than (b) chars available.
; Upshift any lower case characters.
; a,f,b,h,l,ix
ldfld:    call    lastch;        on (ix)^ and load it
    jrz    ldfld4;        delimiter
    inx    h
    cpi    '*'
    jrnz    ldfld1
    mvi    m,'?';        expand '*'
    jr    ldfld2;        dont skip past it
ldfld1:    call    upshft;        upshift any lower case
    mov    m,a
    call    nextch
ldfld2:    djnz    ldfld
    call    lastch;        on (de)^ and load it
    rz;            a delimiter
ldfld3:    call    nextch;        else skip to a delimiter
    rz
    jr    ldfld3
ldfld4:    inx    h
    mvi    m,' ';        blank fill
    djnz    ldfld4
    ret
;
; getdu returns any "du" spec. in b and c, with c = user, b = drv
; The default user is signified by a -1 value, default drive by 0
; At entry, IX points to the start of the field to be parsed. At
; exit, either IX is unchanged (no du found), or points to ':'
; a,f,b,c,d,e,ix
getdu:    lxi    b,0ffh;        set defaults
    pushix
    pop    d;        pre-scan for valid du field
    ldax    d
    call    upshft;        2.1 - No ':' abort here
    call    qnum
    jrnc    getdu1;        1st char digit, no d
    cpi    '@'
    rc;            < '@', no du spec
    cpi    'P'+1
    rnc;            > P, no du spec
    inx    d
    ldax    d
    cpi    ':'
    jrz    getdu2;        d spec only
    call    qnum
    rc;            no 'du' spec
getdu1:    inx    d
    ldax    d
    cpi    ':'
    jrz    getdu2;        du spec found
    call    qnum
    rc;            no du spec
    inx    d
    ldax    d
    cpi    ':'
    rnz;            not terminal ':', no du spec
;    "    "
; prescan found a valid du format, now load it
getdu2:    call    lastch
    call    qnum
    jrnc    getdu3;        digit, no d portion
    call    upshft
    sui    '@'
    mov    b,a;        save d portion
    call    nextch
getdu3:    cpi    ':'
    rz;            no 'u' portion
    ani    0fh
    mov    c,a
    call    nextch
    rz;            ':', 1 digit only
    call    dstep;        incorporate
    call    nextch;        and advance to the (known) ':'
    lda    maxusr
    cmp    c
    jrc    help;        User # too large
    ret
;
; Decimal input step. Carry for overflow. c is accumulator, a digit
; a,f,c,d
dstep:    ani    0fh
    mov    d,a
    mov    a,c
    cpi    26
    cmc
    rc;            overflow
    add    a
    add    a
    add    c;        5*
    add    a;        10*
    add    d
    mov    c,a;        result
    ret;            cy for overflow
;
; Get next character from line.  Z flag for a delimiter,
; and abort if the character is illegal. Do not advance past eoln.
; Return char in a and leave IX pointing to it. cy for eoln
; a,f,ix
nextch:    ldx    a,+0
    ora    a
    jrz    lastch;        don't advance past eol
    inxix
;    "    "
; Return last character, as above.  Abort if invalid, cy for eoln
; a,f
lastch:    ldx    a,+0
    ora    a
    stc
    rz;            null is a delimiter
    cpi    '=';        and all these
    rz
    cpi    '_'
    rz
    cpi    '.'
    rz
    cpi    ':'
    rz
    cpi    ';'
    rz
    cpi    '<'
    rz
    cpi    '>';        Redirection chars
    rz
    cpi    ',';        Operand separator
    rz
    cpi    '|';        Piping  separator
    rz;
;    "    "
; Check white space, abort on illegal chars. z flag for white
qwhite:    cpi    tab
    rz;            white space is a delimiter
    cpi    ' '
    jrc    help;        abort on illegals
    ret
;
; skip blanks and tabs in input line.  Abort on illegal chars.
; return the 1st non-blank char. found.
; a,f,ix
skipbk:    call    lastch
    rc;            eoln
skip1:    call    qwhite
    rnz;            not white space
;    "    "
; Effectively "call nextch ! call skipbk"
next:    call    nextch
    jrnc    skip1
    ret;            eoln
;
; hl := hl + a
; a,f,h,l
index:    add    l
    mov    l,a
    rnc
    inr    h
    ret
;
; load (a+c)th char from defdma array
; a,f,h,l
idxac:    lxi    h,defdma
    add    c
    call    index
    mov    a,m
    ret
;
; crlf, then tstr
; a,f,h,l
tstrc:    call    crlf
;    "    "
; string (hl) to console until 0 byte
; a,f,h,l
tstr:    mov    a,m
    ora    a
    rz
    inx    h
    call    couta
    jr    tstr
;
help:    lxi    h,hlpmsg
;    "    "
; exit with message
msgxit:    call    tstrc
    jr    done
;
; no time stamp message & exit
notime:    lxi    h,notimemsg
    jr    msgxit
;
; jam fcb to all wild cards
mkwild:    lxi    h,fname
    mvi    b,11
mkwld1:    mvi    m,'?'
    inx    h
    djnz    mkwld1
    ret
;
; one blank to console
blk:    mvi    b,1
;    "    "
; blank to console
blks:    mvi    a,' '
    call    couta
    djnz    blks
    ret
;
; Main program operation
begin:    lxi    h,0
    dad    sp
    shld    stksav
    lxi    sp,stksav
    lxi    h,defdma
    mov    a,m
    ora    a
    inx    h
    push    h
    popix;            init input scanner
    jz    help;        empty input line
    call    skipbk
    jc    help;        or only blanks
    call    parse
    lda    fname
    cpi    ' '
    cz    mkwild;        must be a du spec
    call    setdu
    call    ffind;        sets de := ^fcbdrv
    cnz    flist;        If any found, list them
done:    lhld    stksav
    sphl
    ret
;
; List files found
flist:    push    psw
    lda    defdma + 060h
    cpi    021h
    jrnz    notime;        and abort
    lxi    h,head
    call    tstrc
    pop    psw
flist1:    dcr    a;        compensate for file-find inr
    push    psw
    mvi    c,060h
    add    a;        2*
    mov    b,a
    add    a;        4*
    add    a;        8*
    add    b;        10*
    adi    2;        displacement of 1st stamp
    call    idxac;        point to time stamp
    lxi    d,fcreat
    lxi    b,10
    ldir;            move into fcb on 1st
; really want min of all create, max of modify/access for file
    pop    psw
    rrc
    rrc
    rrc
    ani    060h
    mvi    c,1
    call    idxac;        point to DIR entry
    call    crlf
    lda    fcbdrv
    adi    '@'
    call    couta
    lda    fcbusr
    call    putnum
    mvi    a,':'
    call    couta
    mvi    b,8
    call    tname
    mvi    a,'.'
    call    couta
    mvi    b,3
    call    tname
    mvi    b,2
    call    blks
    call    dates
    call    qbreak
    rnz
    call    srchn
    jnz    flist1
    ret
;
dates:    lhld    fcreat
    call    date
    mvi    b,2
    call    blks
    lhld    fmodif
    call    date
    call    blk
    lhld    fmodif+2
    call    time
    mvi    b,2
    call    blks
    lhld    facces
    call    date
    call    blk
    lhld    facces+2
    call    time
    ret
;
date:    mvi    b,8
    mov    a,h
    ora    l
    jz    blks
    call    drtodate
    mov    a,c;        year
    call    t2hx
    mvi    a,'/'
    call    couta
    mov    a,d
    call    t2hx
    mvi    a,'/'
    call    couta
    mov    a,e
    jmp    t2hx
;
time:    mvi    b,5
    mov    a,h
    ora    l
    jz    blks
    mov    a,l
    call    t2hx
    mvi    a,':'
    call    couta
    mov    a,h
;    "    "
t2hx:    push    psw
    rlc
    rlc
    rlc
    rlc
    call    t1hx
    pop    psw
;    "    "
t1hx:    ani    0fh
    adi    090h
    daa
    aci    040h
    daa
    jmp    couta
;
; type b chars from hl^
tname:    mov    a,m
    ani    07fh
    call    couta
    inx    h
    djnz    tname
    ret
;
; days per month, except leap year. Leading dummy 0 for month 0
mtbl:    db    0,31,28,31,30,31,30,31,31,30,31,30,31
;
; Convert (a) in binary to BCD. No overflow check. Return z flag.
; a,f
binbcd:    push    b
    lxi    b,0affh;        b := 10, c := -1
bbcd1:    inr c !    sub b !jrnc bbcd1;    divide by 10
    add    b;            correct remainder
    mov    b,a
    mov    a,c;            quotient
    add a !    add a !    add a !    add a;    * 16. Cy for o'flow
    add    b;            + remainder. clears cy
    pop    b
    ret
;
; PROCEDURE drtodate(thedate : integer; VAR yr, mo, day : integer);
; (* 1 Jan 1978 corresponds to Digital Research date = 1  *)
; (* BUG - cannot handle negative values for dates > 2067 *)
;
;   VAR
;     i, y1        : integer;
;     dayspermonth : ARRAY[1..12] OF 1..31;
;
;   BEGIN (* drtodate *)
;   FOR i := 1 TO 12 DO dayspermonth[i] := 31;
;   dayspermonth[4] := 30; dayspermonth[6] := 30;
;   dayspermonth[9] := 30; dayspermonth[11] := 30;
;   IF thedate > 731 THEN BEGIN (* avoid overflows *)
;     yr := 1980; thedate := thedate - 731; END
;   ELSE BEGIN
;     thedate := thedate + 730; yr := 1976; END;
;   (* 0..365=y0; 366..730=y1; 731..1095=y2; 1096..1460=y3 *)
;   i := thedate DIV 1461; thedate := thedate MOD 1461;
;   y1 := (thedate-1) DIV 365; yr := yr + y1 + 4*i;
;   IF y1 = 0 THEN (* leap year *) dayspermonth[2] := 29
;   ELSE BEGIN
;     thedate := thedate - 1; (* 366 -> 365 -> 1 Jan *)
;     dayspermonth[2] := 28; END;
;   day := thedate - 365*y1 + 1; mo := 1;
;   WHILE day > dayspermonth[mo] DO BEGIN
;     day := day - dayspermonth[mo];
;     mo := succ(mo); END;
;   END; (* drtodate *)
;
; Incorporate (a) in year (c), overflows to century (b)
addyr:    add    c
    jnc    addyr1;        <256
    sui    100;        256..276
    jmp    addyr2
addyr1:    dcr    b
addyr2:    inr    b
    sui    100
    jnc    addyr2
    adi    100;        b = century, c = year MOD 100
    mov    c,a
    ret
;
; divide hl by -de, rdr to hl, quotient to a
divd:    mvi    a,-1
divd1:    inr    a
    dad    d
    jc    divd1
    push    psw
    mov    a,l
    sub    e
    mov    l,a
    mov    a,h
    sbb    d
    mov    h,a
    pop    psw
    ret
;
; Input  : hl = drdate (days since 78/1/1, 1 = 78/1/1)
; Output : b, c, d, e = cent, year, month, day (binary)
; a,f,b,c,d,e,h,l
drtodate:
    lxi    b,256*19 + 76;    731 represents 80/1/1
    push    h
    lxi    d,-731
    dad    d
    pop    h
    jnc    drd1;        before 80/1/1
    dad    d;        on or after 80/1/1
    mvi    c,80;        now 0 represents 80/1/1
    jmp    drd2
drd1:    lxi    d,730
    dad    d;        now 731 represents 78/1/1
drd2:    lxi    d,-1461
    call    divd;        get quad years since base (in c)
    add    a
    add    a;        4 * i.  180 max
    call    addyr;        yr := yr + 4 * i
    mov    a,h
    ora    l
    jz    drd3;        At Jan 1, leap year
    dcx    h;        thedate := thedate - 1
    lxi    d,-365;        so year thresholds come out right
    call    divd;        thedate := thedate MOD 365
    push    psw;        y1 := a := thedate DIV 365
    call    addyr;        yr := yr+y1
    pop    psw;        0 for leapyear
    jnz    drd5;        not a leap year
    inx    h;        thedate := thedate+1 (1..365)
drd3:    mvi    a,29
    sta    mtbl+2
drd5:    xchg
    lxi    h,mtbl
    push    b
    mvi    b,0;        mo := 0
drd6:    inx    h;        WHILE
    inr    b;         day := day-dayspermo[mo := mo+1] >= 0
    mov    a,e;            DO (* again *)
    sub    m
    mov    e,a
    mov    a,d
    sbi    0
    mov    d,a
    jnc    drd6
    mov    a,e;        day := day+dayspermo[mo]
    add    m
    mov    e,a;        range 0..pred(dayspermo[mo])
    adc    d
    sub    e
    mov    d,a
    xchg
    mov    d,b
    pop    b
    mov    e,l
    inr    e;        make result 1 based
    mvi    a,28
    sta    mtbl+2;        restore month table
    mov    a,b
    call    binbcd
    mov    b,a
    mov    a,c
    call    binbcd
    mov    c,a
    mov    a,d
    call    binbcd
    mov    d,a
    mov    a,e
    call    binbcd
    mov    e,a
    ret
;
hlpmsg:        db    'FDATE ver. '
        db    ver / 10 + '0', '.', ver mod 10 + '0'
        db    'by C.B. Falconer',cr,lf,lf
        db    'Usage: FDATE [d[u]:][afn.aft]',cr,lf
        db    'shows timestamps for DOS+ directories',0
notimemsg:    db    'No time stamps on this volume',0
head:        db    'd/u:Filename.Typ  Created   '
        db    '---Modified---  ---Accessed---',cr,lf
        db    '--- -------- ---  --------  '
        db    '--------------  --------------',0
;
; NOTE: the ",0" in ds statements ensures the areas are 0 filled
;
; File control block and receiver of parse fields (34 bytes)
fcbusr:    ds    1
fcbdrv:    ds    1
fname:    ds    8
ftype:    ds    3
    ds    3
    ds    1
fcreat:    ds    2;        date created or disk map
fmodif:    ds    4;        date/time modified
facces:    ds    4;        date/time accessed
;
; Parsing
lastwd:    ds    2;        start of current word in iobuff
;
    ds    64;        stack space
stksav:    ds    2;        save entry stack
;
    end
0▐