path: root/system/dos/1.8.7/src/dir.dos

PACKET dir DEFINES                            (* Copyright (c) 1986, 87 *)
                                              (* Frank Klapper          *)
  open dir,                                   (* 02.03.88               *)
  insert dir entry,
  delete dir entry,
  init dir ds,
  file info,
  format dir,

  dir list,
  file   exists,
  subdir exists,
  all files,
  all subdirs:
 
LET max dir entrys = 1000;

(*-------------------------------------------------------------------------*)

INITFLAG VAR dir block ds used := FALSE;
DATASPACE VAR dir block ds;
BOUND STRUCT (ALIGN dummy, ROW 64 REAL daten) VAR dir block;
REAL VAR last read dir block no;

PROC init dir block io:
  last read dir block no := -1.0;
  IF NOT initialized (dir block ds used)
    THEN dir block ds := nilspace;
         dir block := dir block ds
  FI.

END PROC init dir block io;

PROC read dir block (REAL CONST block nr):
  IF last read dir block no <> block nr
    THEN last read dir block no := -1.0;
         read disk block and close work if error (dir block ds, 2, block nr);
         last read dir block no := block nr
  FI.

END PROC read dir block;

PROC write dir block (REAL CONST block nr):
  write disk block and close work if error (dir block ds, 2, block nr);
  last read dir block no := block nr.

END PROC write dir block;

PROC write dir block:
  IF last read dir block no < 0.0
    THEN error stop ("Lesefehler")
  FI;
  write dir block (last read dir block no)

END PROC write dir block;

PROC get dir entry (TEXT VAR entry buffer, INT CONST block entry no):
  (* 0 <= block entry no <= 15 *)
  entry buffer := 32 * ".";
  INT CONST replace offset := 4 * block entry no;
  replace (entry buffer, 1, dir block.daten [replace offset + 1]);
  replace (entry buffer, 2, dir block.daten [replace offset + 2]);
  replace (entry buffer, 3, dir block.daten [replace offset + 3]);
  replace (entry buffer, 4, dir block.daten [replace offset + 4]).

END PROC get dir entry;

PROC put dir entry (TEXT CONST entry buffer, INT CONST block entry no):
  (* 0 <= block entry no <= 15 *)
  INT CONST offset := 4 * block entry no;
  dir block.daten [offset + 1] := entry buffer RSUB 1;
  dir block.daten [offset + 2] := entry buffer RSUB 2;
  dir block.daten [offset + 3] := entry buffer RSUB 3;
  dir block.daten [offset + 4] := entry buffer RSUB 4.

END PROC put dir entry;

(*-------------------------------------------------------------------------*)

LET DIRPOS = REAL;                  (* 16.0 * msdos block nr + entry no *)
                                    (* 0 <= entry no <= 15              *)

DIRPOS PROC dirpos (REAL CONST block nr, INT CONST entry nr):
  block nr * 16.0 + real (entry nr).

END PROC dir pos;

REAL PROC block no (DIRPOS CONST p):
  floor (p / 16.0)

END PROC block no;

INT PROC entry no (DIRPOS CONST p):
  int (p MOD 16.0)

END PROC entry no;

PROC incr (DIRPOS VAR p):
  p INCR 1.0.

END PROC incr;

(*-------------------------------------------------------------------------*)

LET FREELIST = STRUCT (ROW max dir entrys DIRPOS stack,
                       INT stacktop,
                       DIRPOS begin of free area,
                              end of dir,
                       REAL dir root);                  (* erste Clusterno, 0 für Main Dir *)
 
PROC init free list (FREELIST VAR flist, REAL CONST root):
  flist.stacktop           := 0;
  flist.begin of free area := dir pos (9.0e99, 0);
  flist.end of dir         := dir pos (-1.0, 0);
  flist.dir root           := root.

END PROC init free list;
 
PROC store (FREELIST VAR flist, DIRPOS CONST free pos):
  flist.stacktop INCR 1;
  flist.stack [flist.stack top] := free pos.

END PROC store;

PROC store begin of free area (FREELIST VAR flist, DIRPOS CONST begin):
  flist.begin of free area := begin

END PROC store begin of free area;

PROC store end of dir (FREELIST VAR flist, DIRPOS CONST end):
  flist.end of dir := end

END PROC store end of dir;

DIRPOS PROC free dirpos (FREELIST VAR flist):
  enable stop;
  DIRPOS VAR result;
  IF flist.stacktop > 0
    THEN pop
    ELIF NOT free area empty
    THEN first of free area
    ELIF expansion alloweded
    THEN allocate new dir cluster;
         result := free dirpos (flist)
    ELSE error stop ("Directory voll")
  FI;
  result.

pop:
  result := flist.stack [flist.stacktop];
  flist.stacktop DECR 1.

free area empty:
  flist.begin of free area > flist.end of dir.

first of free area:
  result := flist.begin of free area;
  incr (flist.begin of free area).

expansion alloweded:
  flist.dir root >= 2.0.

allocate new dir cluster:
  REAL CONST new dir cluster :: available fat entry;
  REAL VAR last entry no;
  search last entry no of fat chain;
  fat entry (new dir cluster, last fat chain entry);
  fat entry (last entry no, new dir cluster);
  write fat;
  store begin of free area (flist, dir pos (first new block, 0));
  store end   of dir       (flist, dir pos (last  new block, 15));
  init new dir cluster.

search last entry no of fat chain:
  last entry no := flist.dir root;
  WHILE NOT is last fat chain entry (fat entry (last entry no)) REP
    last entry no := fat entry (last entry no)
  PER.

first new block:
  begin of cluster (new dir cluster).

last new block:
  begin of cluster (new dir cluster) + real (sectors per cluster - 1).

init new dir cluster:
  TEXT CONST empty dir entry :: 32 * ""0"";
  INT VAR i;
  FOR i FROM 0 UPTO 15 REP
    put dir entry (empty dir entry, i)
  PER;
  disable stop;
  REAL VAR block no := first new block;
  WHILE block no <= last new block REP
    write dir block (block no)
  PER.

END PROC free dirpos; 

(*-------------------------------------------------------------------------*)

LET FILEENTRY = STRUCT (TEXT date and time,
                        REAL size,
                             first cluster, 
                        DIRPOS dirpos),

    FILELIST = STRUCT (THESAURUS thes,
                       ROW max dir entrys FILEENTRY entry);

PROC init file list (FILELIST VAR flist):
  flist.thes := empty thesaurus.

END PROC init file list;

PROC store file entry (FILELIST VAR flist, TEXT CONST entry text, DIRPOS CONST position):
  INT VAR entry index;
  insert (flist.thes, file name, entry index);
  store file entry (flist.entry [entry index], entry text, position).
 
file name:
  TEXT CONST name pre  :: compress (subtext (entry text, 1, 8)),
             name post :: compress (subtext (entry text, 9, 11));
  IF name post <> ""
    THEN name pre + "." + name post
    ELSE name pre
  FI.

END PROC store file entry;

PROC store file entry (FILEENTRY VAR fentry, TEXT CONST entry text, DIRPOS CONST position):
  fentry.first cluster := real (entry text ISUB 14);
  fentry.date and time := dos date + "  " + dos time;
  fentry.size          := dint (entry text ISUB 15, entry text ISUB 16);
  fentry.dirpos        := position.

dos date:
  day + "." + month + "." + year. 
 
day: 
  text2 (code (entry text SUB 25) MOD 32).
 
month:
  text2 (code (entry text SUB 25) DIV 32 + 8 * (code (entry text SUB 26) MOD 2)).
 
year:
  text (80 + code (entry text SUB 26) DIV 2, 2).

dos time:
  hour + ":" + minute. 
 
hour: 
  text2 (code (entry text SUB 24) DIV 8).
 
minute: 
  text2 (code (entry text SUB 23) DIV 32 + 8 * (code (entry text SUB 24) MOD 8)).
 
END PROC store file entry;

TEXT PROC text2 (INT CONST intvalue):
  IF intvalue < 10
    THEN "0" + text (intvalue)
    ELSE text (int value)
  FI.

END PROC text2;

DIRPOS PROC file entry pos (FILELIST CONST flist, TEXT CONST file name):
  INT CONST link index :: link (flist.thes, file name);
  IF link index = 0
    THEN error stop ("Die Datei """ + file name + """ gibt es nicht")
  FI;
  flist.entry [link index].dir pos.

END PROC file entry pos;

PROC delete (FILELIST VAR flist, TEXT CONST file name):
  INT VAR dummy;
  delete (flist.thes, file name, dummy).

END PROC delete;

PROC file info (FILELIST CONST flist, TEXT CONST file name, REAL VAR first cluster no, storage):
  INT CONST link index :: link (flist.thes, file name);
  IF link index = 0
    THEN error stop ("Die Datei """ + file name + """ gibt es nicht")
  FI;
  first cluster no := flist.entry [link index].first cluster;
  storage          := flist.entry [link index].size

END PROC file info;

BOOL PROC contains (FILELIST VAR flist, TEXT CONST file name):
  flist.thes CONTAINS file name

END PROC contains;

PROC list (FILE VAR f, FILELIST CONST flist):
  INT VAR index := 0;
  TEXT VAR name;
  get (flist.thes, name, index);
  WHILE index > 0 REP
    list file;
    get (flist.thes, name, index)
  PER.

list file:
  write (f, centered name);
  write (f, "  ");
  write (f, text (flist.entry [index].size, 11, 0));
  write (f, " Bytes belegt      ");
  write (f, flist.entry [index].date and time); 
(*COND TEST*)
  write (f, "  +++  "); 
  write (f, text (flist.entry [index].first cluster)); 
(*ENDCOND*)
  line (f).

centered name:
  INT VAR point pos := pos (name, ".");
  IF point pos > 0
    THEN name pre + "." + name post
    ELSE text (name, 12)
  FI.

name pre:
  text (subtext (name, 1, point pos - 1), 8).

name post:
  text (subtext (name, point pos + 1, point pos + 4), 3).
 
END PROC list;

(*-------------------------------------------------------------------------*)
 
LET DIRENTRY = REAL,

    DIRLIST = STRUCT (THESAURUS thes,
                      ROW max dir entrys DIRENTRY entry);

PROC init dir list (DIRLIST VAR dlist):
  dlist.thes := empty thesaurus.

END PROC init dir list;

PROC store subdir entry (DIRLIST VAR dlist, TEXT CONST entry text):
  INT VAR entry index;
  insert (dlist.thes, subdir name, entry index);
  dlist.entry [entry index] := real (entry text ISUB 14).

subdir name:
  TEXT CONST name pre  :: compress (subtext (entry text, 1, 8)),
             name post :: compress (subtext (entry text, 9, 11));
  IF name post <> ""
    THEN name pre + "." + name post
    ELSE name pre
  FI.

END PROC store subdir entry;

REAL PROC first cluster of subdir (DIRLIST CONST dlist, TEXT CONST name):
  INT CONST link index := link (dlist.thes, name);
  IF link index = 0
    THEN error stop ("Das Unterverzeichnis """ + name + """ gibt es nicht")
  FI;
  dlist.entry [link index].

END PROC first cluster of subdir;

BOOL PROC contains (DIRLIST CONST dlist, TEXT CONST subdir name):
  dlist.thes CONTAINS subdir name

END PROC contains;

PROC list (FILE VAR f, DIRLIST CONST dlist):
  INT VAR index := 0;
  TEXT VAR name;
  get (dlist.thes, name, index);
  WHILE index > 0 REP
    list dir;
    get (dlist.thes, name, index)
  PER.

list dir:
  write (f, centered name);
  write (f, "   <DIR>");
(*COND TEST*)
  write (f, "  +++  ");                                 
  write (f, text (dlist.entry [index]));  
(*ENDCOND*)
  line (f).

centered name:
  INT VAR point pos := pos (name, ".");
  IF point pos > 0
    THEN name pre + "." + name post
    ELSE text (name, 12)
  FI.

name pre:
  text (subtext (name, 1, point pos - 1), 8).

name post:
  text (subtext (name, point pos + 1, point pos + 4), 3).
 
END PROC list;

(*-------------------------------------------------------------------------*)

LET DIR = BOUND STRUCT (FILELIST filelist,
                        DIRLIST dirlist, 
                        FREELIST freelist,
                        TEXT path);
 
DIR VAR dir;
DATASPACE VAR dir ds;
INITFLAG VAR dir ds used := FALSE;

PROC open dir (TEXT CONST path string):
  init dir block io;
  init dir ds;
  dir.path := path string;
  load main dir;
  TEXT VAR rest path := path string;
  WHILE rest path <> "" REP
    TEXT CONST sub dir name := next sub dir name (rest path);
    load sub dir
  PER.

load main dir:
  init file list (dir.filelist);
  init dir  list (dir.dirlist);
  init free list (dir.free list, 0.0);
  store end of dir (dir.freelist, dirpos (last main dir sector, 15));
  BOOL VAR was last dir sector := FALSE;
  REAL VAR block no := first main dir sector;
  INT VAR i;
  FOR i FROM 1 UPTO dir sectors REP
      load dir block (block no, was last dir sector);
      block no INCR 1.0
      UNTIL was last dir sector
  PER. 

first main dir sector:
  real (begin of dir).

last main dir sector:
  real (begin of dir + dir sectors - 1).

load sub dir:
  REAL VAR cluster no := first cluster of sub dir (dir.dirlist, sub dir name);
  was last dir sector := FALSE;
  init file list (dir.filelist);
  init dir  list (dir.dirlist);
  init free list (dir.free list, cluster no);
  WHILE NOT is last fat chain entry (cluster no) REP
    load sub dir entrys of cluster;
    cluster no := fat entry (cluster no)
    UNTIL was last dir sector
  PER.

load sub dir entrys of cluster:
  store end of dir (dir.freelist, dirpos (last block no of cluster, 15));
  block no := begin of cluster (cluster no);
  FOR i FROM 1 UPTO sectors per cluster REP
    load dir block (block no, was last dir sector);
    block no INCR 1.0
    UNTIL was last dir sector
  PER.

last block no of cluster:
  begin of cluster (cluster no) + real (sectors per cluster - 1).

END PROC open dir;

PROC load dir block (REAL CONST block no, BOOL VAR was last block): 
  was last block := FALSE;
  read dir block (block no);
  INT VAR entry no;
  TEXT VAR entry;
  FOR entry no FROM 0 UPTO 15 REP 
    get dir entry (entry, entry no);
    process entry
    UNTIL was last block
  PER.

process entry:
  SELECT pos (""0"."229"", entry SUB 1) OF
    CASE 1: end of dir search
    CASE 2: (* root des aktuellen directorys oder des übergeordneten, also nichts tun *)
    CASE 3: free entry
    OTHERWISE volume label or file entry or subdir entry
  END SELECT.

end of dir search:
  was last block := TRUE;
  store begin of free area (dir.freelist, dir pos (block no, entry no)).

free entry:
  store (dir.freelist, dir pos (block no, entry no)).

volume label or file entry or subdir entry:
  INT CONST byte 11 :: code (entry SUB 12);
  IF (byte 11 AND 8) > 0
    THEN (* volume label *)
  ELIF (byte 11 AND 16) > 0
    THEN sub dir entry
    ELSE file entry
  FI.

sub dir entry:
  store subdir entry (dir.dir list, entry).

file entry:
  store file entry (dir.file list, entry, dir pos (block no, entry no)).

END PROC load dir block; 
 
TEXT PROC next subdir name (TEXT VAR path string):
  TEXT VAR subdir name;
  IF (path string SUB 1) <> "\"
    THEN error stop ("ungültige Pfadbezeichnung")
  FI;
  INT CONST backslash pos :: pos (path string, "\", 2);
  IF backslash pos = 0
    THEN subdir name := subtext (path string, 2);
         path string := ""
    ELSE subdir name := subtext (path string, 2, backslash pos - 1);
         path string := subtext (path string, backslash pos)
  FI;
  dos name (subdir name, read modus).

END PROC next subdir name;

PROC init dir ds:
  IF initialized (dir ds used)
    THEN forget (dir ds)
  FI;
  dir ds := nilspace;
  dir := dir ds.

END PROC init dir ds;

PROC insert dir entry (TEXT CONST name, REAL CONST start cluster, storage):
  DIRPOS CONST ins pos :: free dirpos (dir.free list);
  TEXT CONST entry string :: entry name + ""32"" + (10 * ""0"") + dos time +
                             dos date + entry start cluster + entry storage;
  write entry on disk;
  write entry in dir ds.

entry name:
  INT CONST point pos := pos (name, ".");
  IF point pos > 0
    THEN subtext (name, 1, point pos - 1) + (9 - point pos) * " " +
         subtext (name, point pos + 1) + (3 - LENGTH name + point pos) * " "
    ELSE name + (11 - LENGTH name) * " "
  FI.
 
dos time:
  TEXT CONST akt time :: time of day (clock (1));
  code ((minute MOD 8) * 32) + code (8 * hour + minute DIV 8).

hour:
  int (subtext (akt time, 1, 2)).

minute:
  int (subtext (akt time, 4, 5)).

dos date:
  TEXT CONST akt date :: date (clock (1));
  code (32 * (month MOD 8) + day) + code ((year - 80) * 2 + month DIV 8).

day: 
  int (subtext (akt date, 1, 2)).

month:
  int (subtext (akt date, 4, 5)).

year:
  int (subtext (akt date, 7, 8)).

entry start cluster:
  TEXT VAR buffer2 := "12";
  replace (buffer2, 1, low word (start cluster));
  buffer2.

entry storage:
  TEXT VAR buffer4 := "1234";
  replace (buffer4, 1, low  word (storage));
  replace (buffer4, 2, high word (storage));
  buffer4.

write entry on disk:
  read dir block (block no (ins pos));
  put dir entry (entry string, entry no (ins pos));
  write dir block.

write entry in dir ds:
  store file entry (dir.file list, entry string, ins pos).

END PROC insert dir entry;

PROC delete dir entry (TEXT CONST name):
  TEXT VAR entry;
  DIRPOS CONST del pos :: file entry pos (dir.filelist, name);
  read dir block (block no (del pos));
  get dir entry (entry, entry no (del pos));
  put dir entry (""229"" + subtext (entry, 2, 32), entry no (del pos));
  write dir block;
  delete (dir.filelist, name);
  store (dir.freelist, del pos).

END PROC delete dir entry;

PROC format dir:
  init dir block io;
  init dir ds;
  build empty dir block;
  REAL VAR block no := real (begin of dir);
  disable stop;
  FOR i FROM 1 UPTO dir sectors REP
    write dir block (block no);
    block no INCR 1.0
  PER;
  enable stop;
  dir.path := "";
  init file list (dir.file list);
  init dir  list (dir.dir  list);
  init free list (dir.free list, 0.0);
  store begin of free area (dir.free list, dir pos (real (begin of dir), 0));
  store end of dir (dir.free list, dir pos (last main dir sector, 15)).

build empty dir block:
  INT VAR i;
  FOR i FROM 0 UPTO 15 REP
    put dir entry (32 * ""0"",  i)
  PER.

last main dir sector:
  real (begin of dir + dir sectors - 1).

END PROC format dir;
 
PROC file info (TEXT CONST file name, REAL VAR start cluster, size):
  file info (dir.file list, file name, start cluster, size)

END PROC file info;

THESAURUS PROC all files:
  THESAURUS VAR t := dir.filelist.thes;
  t

END PROC all files;

THESAURUS PROC all subdirs:
  dir.dirlist.thes

END PROC all subdirs;

BOOL PROC file exists (TEXT CONST file name):
  contains (dir.filelist, file name)

END PROC file exists;

BOOL PROC subdir exists (TEXT CONST subdir name):
  contains (dir.dirlist, subdir name)

END PROC subdir exists;

PROC dir list (DATASPACE VAR ds):
  open list file;
  head line (list file, list file head);
  list (list file, dir.file list);
  list (list file, dir.dir list).

open list file:
  forget (ds);
  ds := nilspace;
  FILE VAR list file := sequential file (output, ds);
  putline (list file, "").
 
list file head:
  "DOS" + path string.

path string:
  IF dir.path <> ""
    THEN "     PATH: " + dir.path
    ELSE ""
  FI.

END PROC dir list;

END PACKET dir;