PACKET dos single DEFINES                       (* Copyright (C) 1985 *)
                                                (* Frank Klapper      *)
                                                (* 11.09.87           *)
  /,
  dos,
  provide dos channel,
  archive,
  reserve,
  release,
  save,
  fetch,
  erase,
  check,
  exists,
  ALL,
  SOME,
  clear,
  list, 
  format:

LET std archive channel = 31,
    main    channel = 1;

INT VAR dos channel := std archive channel;
INT VAR fetch save modus;

TYPE DOSTASK = TEXT;

DOSTASK CONST dos := "DOS";

OP := (DOSTASK VAR d, TEXT CONST t):
  CONCR (d) := t

END OP :=;

DOSTASK OP / (TEXT CONST text):
  DOSTASK VAR d;
  CONCR (d) := text;
  d

END OP /;

BOOL PROC is dostask (DOSTASK CONST d):
  CONCR (d) = "DOS"

END PROC is dos task;

PROC provide dos channel (INT CONST channel no):
  dos channel := channel no

END PROC provide dos channel;

DATASPACE VAR space := nilspace;
forget (space);

PROC reserve (TEXT CONST string, DOSTASK CONST task):
   IF is dostask (task)
    THEN fetch save modus := save fetch mode (string);
         open dos disk (path (string))
    ELSE error stop ("die angesprochene Task existiert nicht")
  FI.

END PROC reserve;

PROC archive (TEXT CONST string, DOSTASK CONST task):
  reserve (string, task)

END PROC archive;

PROC release (DOSTASK CONST task):
  IF is dos task (task)
    THEN close dos disk
    ELSE error stop ("die angesprochene Task existiert nicht")
  FI.

END PROC release;

PROC fetch (TEXT CONST name, DOSTASK CONST from):
  IF is dostask (from)
    THEN fetch from dos disk
    ELSE error stop ("die angesprochene Task existiert nicht")
  FI.

fetch from dos disk:
  IF NOT exists (name) COR overwrite permitted
    THEN do fetch 
  FI.

overwrite permitted:
  say ("eigene Datei """) ; 
  say (name) ; 
  yes (""" auf der Diskette ueberschreiben"). 

do fetch:
  last param (name);
  disable stop;
  continue (dos channel);
  fetch (dos name (name, read modus), space, fetch save modus);
  continue (main channel);
  IF NOT is error
    THEN forget (name, quiet);
         copy (space, name)
  FI;
  forget (space).

END PROC fetch;

PROC erase (TEXT CONST name, DOSTASK CONST task):
  IF is dos task (task)
    THEN do erase dos file
    ELSE error stop ("die angesprochene Task existiert nicht")
  FI.

do erase dos file:
  IF NOT exists (name, /"DOS")
    THEN error stop ("die Datei """ + name + """ gibt es nicht")
  ELIF yes ("""" + dos name (name, read modus)+ """ auf Der Diskette loeschen")
    THEN disable stop;
         continue (dos channel);
         erase dos file (dos name (name, read modus));
         continue (main channel)
  FI.

END PROC erase;

PROC save (TEXT CONST name, DOSTASK CONST task):
  IF is dos task (task)
    THEN save to dos disk
    ELSE error stop ("die angesprochene Task existiert nicht")
  FI.

save to dos disk:
  TEXT CONST save file name :: dos name (name, write modus);
  disable stop;
  continue (dos channel);
  IF NOT dos file exists (save file name) COR overwrite permitted
    THEN IF dos file exists (save file name)
           THEN erase dos file (save file name)
         FI;
         save (save file name, old (name), fetch save modus);
  FI;
  continue (main channel).

overwrite permitted:
  continue (main channel);
  BOOL CONST result :: yes ("""" + save file name + """ auf der Diskette ueberschreiben");
  continue (dos channel);
  result.

END PROC save;

PROC check (TEXT CONST name, DOSTASK CONST from):
  IF is dostask (from)
    THEN disable stop;
         continue (dos channel);
         check file (dos name (name, read modus));
         continue (main channel)
    ELSE error stop ("die angesprochene Task existiert nicht")
  FI.

END PROC check;

BOOL PROC exists (TEXT CONST name, DOSTASK CONST task):
  IF is dos task (task)
    THEN disable stop;
         continue (dos channel);
         BOOL VAR dummy := dos file exists (dos name (name, read modus));
         continue (main channel);
         enable stop;
         dummy
    ELSE error stop ("die angesprochene Task existiert nicht"); FALSE
  FI.

END PROC exists;

PROC list (DOSTASK CONST from):
  forget (space);
  space := nilspace;
  FILE VAR list file := sequential file (output, space);
  list (list file, from);
  modify (list file);
  show (list file);
  forget (space).

ENDPROC list;

PROC list (FILE VAR list file, DOSTASK CONST from):
  IF is dos task (from)
    THEN list dos disk
    ELSE error stop ("die angesprochene Task existiert nicht")
  FI.

list dos disk:
  disable stop;
  continue (dos channel);
  dos list (space);
  continue (main channel);
  enable stop;
  output (list file);
  FILE VAR list source := sequential file (output, space);
  TEXT VAR line;
  WHILE NOT eof (list source) REP
    getline (list source, line);
    putline (list file,   line)
  PER.

END PROC list;

THESAURUS OP ALL (DOSTASK CONST task):
  IF is dos task (task)
    THEN disable stop;
         continue (dos channel);
         THESAURUS VAR dummy := all dos files;
         continue (main channel);
         enable stop;
         dummy
    ELSE error stop ("die angesprochene Task existiert nicht"); empty thesaurus
  FI.

END OP ALL;

THESAURUS OP SOME (DOSTASK CONST task):
  IF is dos task (task)
    THEN disable stop;
         continue (dos channel);
         THESAURUS VAR dummy := all dos files;
         continue (main channel);
         enable stop;
         SOME dummy
    ELSE error stop ("die angesprochene Task existiert nicht"); empty thesaurus
  FI.

END OP SOME;

PROC clear (DOSTASK CONST task):
  IF is dos task (task)
    THEN clear disk
    ELSE error stop ("die angesprochene Task existiert nicht")
  FI.

clear disk:
  disable stop;
  IF yes ("Diskette loeschen")
    THEN continue (dos channel);
         clear dos disk;
         continue (main channel)
  FI.

END PROC clear;

PROC format (INT CONST format code, DOSTASK CONST task):
  IF is dos task (task)
    THEN format disk
    ELSE error stop ("die angesprochene Task existiert nicht")
  FI.

format disk:
  disable stop;
  IF yes ("Diskette formatieren")
    THEN continue (dos channel);
         format dos disk (format code);
         continue (main channel)
  FI.

END PROC format;

END PACKET dos single;