DataMuseum.dk

top - download

    Length: 7680 (0x1e00)
    Types: TextFile
    Names: »DATMAN.PAS«

└─⟦42acf21c3⟧ Bits:30005716 PolyPascal-80 v. 3.10 (RC703)
    └─ ⟦this⟧ »DATMAN.PAS« 
└─⟦6367c43c0⟧ Bits:30004325 PolyPascal vers. 3.10 for Butler
    └─ ⟦this⟧ »DATMAN.PAS« 
└─⟦692ac107c⟧ Bits:30005923 PolyPascal-80 V3.10 arbejdsdiskette 1
    └─ ⟦this⟧ »DATMAN.PAS« 
└─⟦725a95225⟧ Bits:30003287 PolyPascal v. 3.10 med eksempler for RC700
    └─ ⟦this⟧ »DATMAN.PAS« 
└─⟦f03928158⟧ Bits:30005922 PolyPascal 3.10 (RC700)
    └─ ⟦this⟧ »DATMAN.PAS« 

TextFile

æ*******************************************************å
æ                                                       å
æ            PolyFile Version 1.10 (CP/M-80)            å
æ                                                       å
æ                     DATMAN module                     å
æ                                                       å
æ                  Copyright (C) 1985                   å
æ               PolyData MicroCenter A/S                å
æ                                                       å
æ*******************************************************å

æ$A+,I-,R-å

TYPE
  p_str14 = STRINGÆ14Å;
  datafile = RECORD
               CASE integer OF
                 0: (f: FILE OF byte;
                     ffre,nfre,int1,int2: integer);
                 1: (fil1,fil2,nrec,recl,crec,fil3: integer;
                     cdrv: byte;
                     cnam: arrayÆ1..8Å of char;
                     ctyp: arrayÆ1..3Å of char);
             END;
  p_keystr = STRINGÆmaxksizeÅ;
  p_idxrec = RECORD
               dr,nr: integer;
               key: p_keystr;
             END;
  p_nodrec = RECORD
               ne: 0..nodesize;
               nr0: integer;
               e: ARRAYÆ1..nodesizeÅ OF p_idxrec;
             END;
  p_nodrcp = ^p_nodrec;
  p_pthrec = RECORD
                nr,ep: integer;
              END;
  p_pthlst = ARRAYÆ1..maxdepthÅ OF p_pthrec;
  indexfile = RECORD
                d: datafile;
                dupkey: boolean;
                klen,rr,pp: integer;
                path: p_pthlst;
              END;
  p_indxfp = ^indexfile;
  p_nbfrec = RECORD
                n: p_nodrec;
                ifp: p_indxfp;
                nr: integer;
                upd: boolean;
              END;
  p_nbfrcp = ^p_nbfrec;
  p_nodbuf = ARRAYÆ1..nbufsizeÅ OF p_nbfrec;
  p_nodmap = ARRAYÆ1..nbufsizeÅ OF integer;
  p_recbuf = RECORD
                  CASE integer OF
                    0: (n: p_nbfrec);
                    1: (r: ARRAYÆ1..maxrsizeÅ OF byte);
                END;

VAR
  iosts: integer;
  ok: boolean;
  p_rbuf: p_recbuf;
  p_nbuf: p_nodbuf;
  p_nmap: p_nodmap;

PROCEDURE iocheck(VAR datf: datafile; r: integer);
VAR
  p: integer;
BEGIN
  IF iosts<>0 THEN WITH datf DO
  BEGIN
    writeln;
    writeln('PolyFile I/O Error ',iosts);
    writeln('File ',chr(cdrv+64),':',cnam,'.',ctyp,' Record ',r);
    writeln('Program terminated');
    halt;
  END;
END;

PROCEDURE getrec(VAR datf: datafile; r: integer; VAR buffer);
VAR
  b: byte AT buffer;
BEGIN
  seek(datf.f,r); read(datf.f,b);
  iosts:=iores; iocheck(datf,r);
END;

PROCEDURE putrec(VAR datf: datafile; r: integer; VAR buffer);
VAR
  b: byte AT buffer;
BEGIN
  seek(datf.f,r); write(datf.f,b);
  iosts:=iores; iocheck(datf,r);
END;

PROCEDURE makefile(VAR datf: datafile; fnam: p_str14; reclen: integer);
BEGIN
  assign(datf.f,fnam); rewrite(datf.f); iosts:=iores;
  IF iosts=3 THEN ok:=false ELSE
  BEGIN
    iocheck(datf,0); datf.recl:=reclen; datf.ffre:=-1;
    datf.nfre:=0; datf.int1:=0; datf.int2:=0;
    move(datf.ffre,p_rbuf,8); putrec(datf,0,p_rbuf);
    ok:=true;
  END;
END;

PROCEDURE openfile(VAR datf: datafile; fnam: p_str14; reclen: integer);
BEGIN
  assign(datf.f,fnam); reset(datf.f); iosts:=iores;
  IF iosts=2 THEN ok:=false ELSE
  BEGIN
    IF iosts=1 THEN iosts:=0;
    iocheck(datf,0); datf.recl:=reclen;
    getrec(datf,0,p_rbuf); move(p_rbuf,datf.ffre,8);
    ok:=true;
  END;
END;

PROCEDURE closefile(VAR datf: datafile);
BEGIN
  move(datf.ffre,p_rbuf,8); putrec(datf,0,p_rbuf);
  close(datf.f); iosts:=iores; iocheck(datf,0);
END;

PROCEDURE addrec(VAR datf: datafile; VAR r: integer; VAR buffer);
BEGIN
  IF datf.ffre=-1 THEN r:=datf.nrec ELSE
  BEGIN
    r:=datf.ffre; getrec(datf,r,p_rbuf);
    move(p_rbuf,datf.ffre,2); datf.nfre:=datf.nfre-1;
  END;
  putrec(datf,r,buffer);
END;

PROCEDURE deleterec(VAR datf: datafile; r: integer);
BEGIN
  move(datf.ffre,p_rbuf,2); putrec(datf,r,p_rbuf);
  datf.ffre:=r; datf.nfre:=datf.nfre+1;
END;

FUNCTION filelen(VAR datf: datafile): integer;
BEGIN
  filelen:=datf.nrec;
END;

FUNCTION usedrecs(VAR datf: datafile): integer;
BEGIN
  usedrecs:=datf.nrec-datf.nfre-1;
END;

PROCEDURE initindex;
VAR
  i: integer;
BEGIN
  FOR i:=1 TO nbufsize DO
  BEGIN
    p_nbufÆiÅ.ifp:=NIL; p_nbufÆiÅ.upd:=false; p_nmapÆiÅ:=i;
  END;
END;

PROCEDURE p_pack(VAR n: p_nodrec; klen: integer);
VAR
  i: integer;
  p: ARRAYÆ0..maxintÅ OF byte AT n;
BEGIN
  IF klen<>maxksize THEN
  FOR i:=1 TO nodesize DO move(n.eÆiÅ,pÆ(i-1)*(klen+5)+3Å,klen+5);
END;

PROCEDURE p_unpack(VAR n: p_nodrec; klen: integer);
VAR
  i: integer;
  p: ARRAYÆ0..maxintÅ OF byte AT n;
BEGIN
  IF klen<>maxksize THEN
  FOR i:=nodesize DOWNTO 1 DO move(pÆ(i-1)*(klen+5)+3Å,n.eÆiÅ,klen+5);
END;

PROCEDURE makeindex(VAR idxf: indexfile; fnam: p_str14; keylen,s: integer);
VAR
  k: integer;
BEGIN
  k:=(keylen+5)*nodesize+3;
  makefile(idxf.d,fnam,k);
  idxf.dupkey:=s<>0; idxf.klen:=keylen;
  idxf.rr:=0; idxf.pp:=0;
END;

PROCEDURE openindex(VAR idxf: indexfile; fnam: p_str14; keylen,s: integer);
VAR
  k: integer;
BEGIN
  k:=(keylen+5)*nodesize+3;
  openfile(idxf.d,fnam,k);
  idxf.dupkey:=s<>0; idxf.klen:=keylen;
  idxf.rr:=idxf.d.int1; idxf.pp:=0;
END;

PROCEDURE closeindex(VAR idxf: indexfile);
VAR
  i: integer;
BEGIN
  FOR i:=1 TO nbufsize DO WITH p_nbufÆiÅ DO
  IF ifp=ptr(addr(idxf)) THEN
  BEGIN
    ifp:=NIL;
    IF upd THEN
    BEGIN
      p_pack(n,idxf.klen); putrec(idxf.d,nr,n); upd:=false;
    END;
  END;
  idxf.d.int1:=idxf.rr; closefile(idxf.d);
END;

PROCEDURE p_last(i: integer);
VAR
  j,k: integer;
BEGIN
  j:=1; WHILE (p_nmapÆjÅ<>i) AND (j<nbufsize) DO j:=j+1;
  FOR k:=j TO nbufsize-1 DO p_nmapÆkÅ:=p_nmapÆk+1Å;
  p_nmapÆnbufsizeÅ:=i;
END;

PROCEDURE p_getn(VAR idxf: indexfile; r: integer; VAR np: p_nodrcp);
VAR
  i,j,k: integer;
  found: boolean;
BEGIN
  found:=false;
  FOR j:=1 TO nbufsize DO IF NOT found THEN WITH p_nbufÆjÅ DO
  IF (ifp=ptr(addr(idxf))) AND (nr=r) THEN
  BEGIN
    i:=j; found:=true;
  END;
  IF NOT found THEN
  BEGIN
    i:=p_nmapÆ1Å;
    WITH p_nbufÆiÅ DO
    BEGIN
      IF upd THEN
      BEGIN
        p_pack(n,ifp^.klen); putrec(ifp^.d,nr,n);
      END;
      getrec(idxf.d,r,n); p_unpack(n,idxf.klen);
      ifp:=ptr(addr(idxf)); nr:=r; upd:=false;
    END;
  END;
  p_last(i); np:=ptr(addr(p_nbufÆiÅ));
END;

PROCEDURE p_newn(VAR idxf: indexfile; VAR r: integer; VAR np: p_nodrcp);
VAR
  i: integer;
BEGIN
  i:=p_nmapÆ1Å;
  WITH p_nbufÆiÅ DO
  BEGIN
    IF upd THEN
    BEGIN
      p_pack(n,ifp^.klen); putrec(ifp^.d,nr,n);
    END;
    addrec(idxf.d,r,n);
    ifp:=ptr(addr(idxf)); nr:=r; upd:=false;
  END;
  p_last(i); np:=ptr(addr(p_nbufÆiÅ));
END;

PROCEDURE p_updn(np: p_nodrcp);
VAR
  p: p_nbfrcp AT np;
BEGIN
  p^.upd:=true;
END;

PROCEDURE p_retn(VAR np: p_nodrcp);
VAR
  p: p_nbfrcp AT np;
BEGIN
  WITH p^ DO
  BEGIN
    deleterec(ifp^.d,nr); ifp:=NIL; upd:=false;
  END;
END;

PROCEDURE p_xkey(VAR k; klen: integer);
VAR
  key: p_keystr AT k;
BEGIN
  IF ord(keyÆ0Å)>klen THEN keyÆ0Å:=chr(klen);
END;

FUNCTION p_ckey(VAR k1,k2; dr1,dr2: integer; dup: boolean): integer;
VAR
  key1: p_keystr AT k1;
  key2: p_keystr AT k2;
BEGIN
  IF key1=key2 THEN
  IF dup THEN p_ckey:=dr1-dr2 ELSE p_ckey:=0 ELSE
  IF key1>key2 THEN p_ckey:=1 ELSE p_ckey:=-1;
END;

PROCEDURE clearkey(VAR idxf: indexfile);
BEGIN
  idxf.pp:=0;
END;
«eof»