PACKET fetch DEFINES (* Copyright (C) 1985, 86, 87 *)
(* Frank Klapper *)
(* 27.04.87 *)
fetch,
check file:
LET ascii = 1,
ascii german = 2,
transparent = 3,
row text = 5,
ds = 6,
dump = 7,
atari st = 10,
ibm = 11,
(*line end chars = ""10""12""13"",*)
min line end char = ""10"",
max line end char = ""13"",
lf = ""10"",
cr = ""13"",
tab code = 9,
lf code = 10,
ff code = 12,
cr code = 13,
ctrl z = ""26"",
page cmd = "#page#",
row text length = 4000,
row text type = 1000;
BOUND STRUCT (INT size,
ROW row text length TEXT cluster row) VAR cluster struct;
FILE VAR file;
TEXT VAR buffer;
INT VAR buffer length;
PROC fetch (TEXT CONST name, DATASPACE VAR file ds, INT CONST mode):
SELECT mode OF
CASE ascii, ascii german, atari st, ibm, transparent:
fetch filemode (file ds, name, mode)
CASE row text : fetch row textmode (file ds, name)
CASE ds : fetch dsmode (file ds, name)
CASE dump : fetch dumpmode (file ds, name)
OTHERWISE error stop ("Unzulässige Betriebsart")
END SELECT.
END PROC fetch;
PROC fetch filemode (DATASPACE VAR file space, TEXT CONST name,
INT CONST code type):
enable stop;
initialize fetch filemode;
open fetch dos file (name);
WHILE NOT was last fetch cluster REP
get text of cluster;
write lines;
(***************************************)
IF lines (file) > 3900
THEN putline (file, ">>> FREMDDATEI FUER EUMEL ZU LANG. ES KÖNNEN DATEN FEHLEN <<<");
LEAVE fetch filemode
FI;
(***************************************)
UNTIL file end via ctrl z
PER;
write last line if necessary;
close fetch dos file.
initialize fetch filemode:
buffer := "";
buffer length := 0;
forget (file space);
file space := nilspace;
file := sequential file (output, file space);
BOOL VAR file end via ctrl z := FALSE.
get text of cluster:
cat next fetch dos cluster (buffer);
IF ascii code
THEN ctrl z is buffer end
FI;
adapt code (buffer, buffer length + 1, code type);
buffer length := length (buffer).
ascii code:
(code type = ascii) OR (code type = ascii german).
ctrl z is buffer end:
INT CONST ctrl z pos :: pos (buffer, ctrl z, buffer length + 1);
file end via ctrl z := ctrl z pos > 0;
IF file end via ctrl z
THEN buffer := subtext (buffer, 1, ctrl z pos - 1);
buffer length := length (buffer)
FI.
write lines:
INT VAR line begin pos := 1, line end pos;
compute line end pos;
WHILE line end pos > 0 REP
putline (file, subtext (buffer, line begin pos, line end pos));
exec (PROC (TEXT CONST, INT CONST) control char conversion, file, code type);
line begin pos := line end pos + 1;
compute line end pos
PER;
buffer := subtext (buffer, line begin pos);
buffer length := length (buffer);
IF buffer length > 5 000
THEN putline (file, buffer);
exec (PROC (TEXT CONST, INT CONST) control char conversion, file, code type);
buffer := "";
buffer length := 0
FI.
compute line end pos:
line end pos := line begin pos;
REP
line end pos := pos (buffer, min line end char, max line end char, line end pos);
INT CONST line end code :: code (buffer SUB line end pos);
SELECT line end code OF
CASE lf code: look for cr
CASE 11 : line end pos INCR 1
CASE cr code: look for lf
END SELECT
UNTIL line end code <> 11
PER.
look for cr:
IF line end pos = buffer length
THEN line end pos := 0
ELIF (buffer SUB line end pos + 1) = cr
THEN line end pos INCR 1
FI.
look for lf:
IF line end pos = buffer length
THEN line end pos := 0
ELIF (buffer SUB line end pos + 1) = lf
THEN line end pos INCR 1
FI.
write last line if necessary:
IF buffer length > 0
THEN putline (file, buffer);
exec (PROC (TEXT CONST, INT CONST) control char conversion, file, code type);
FI.
END PROC fetch filemode;
PROC adapt code (TEXT VAR text buffer, INT CONST start pos, code type):
SELECT code type OF
CASE ascii : cancel bit 8
CASE ascii german: cancel bit 8; ascii german adaption
CASE atari st : atari st adaption
CASE ibm : ibm adaption
(*CASE transparent : do nothing *)
END SELECT.
cancel bit 8:
INT VAR set pos := pos (text buffer, ""128"", ""255"", start pos);
WHILE set pos > 0 REP
replace (text buffer, set pos, seven bit char);
set pos := pos (text buffer, ""128"", ""255"", set pos + 1)
PER.
seven bit char:
code (code (text buffer SUB set pos) AND 127).
ascii german adaption:
change all by replace (text buffer, start pos, "[", "Ä");
change all by replace (text buffer, start pos, "\", "Ö");
change all by replace (text buffer, start pos, "]", "Ü");
change all by replace (text buffer, start pos, "{", "ä");
change all by replace (text buffer, start pos, "|", "ö");
change all by replace (text buffer, start pos, "}", "ü");
change all by replace (text buffer, start pos, "~", "ß").
atari st adaption:
change all by replace (text buffer, start pos, ""142"", "Ä");
change all by replace (text buffer, start pos, ""153"", "Ö");
change all by replace (text buffer, start pos, ""154"", "Ü");
change all by replace (text buffer, start pos, ""132"", "ä");
change all by replace (text buffer, start pos, ""148"", "ö");
change all by replace (text buffer, start pos, ""129"", "ü");
change all by replace (text buffer, start pos, ""158"", "ß").
ibm adaption:
change all by replace (text buffer, start pos, ""142"", "Ä");
change all by replace (text buffer, start pos, ""153"", "Ö");
change all by replace (text buffer, start pos, ""154"", "Ü");
change all by replace (text buffer, start pos, ""132"", "ä");
change all by replace (text buffer, start pos, ""148"", "ö");
change all by replace (text buffer, start pos, ""129"", "ü");
change all by replace (text buffer, start pos, ""225"", "ß").
END PROC adapt code;
PROC change all by replace (TEXT VAR string, INT CONST begin pos,
TEXT CONST old, new):
INT VAR p := pos (string, old, begin pos);
WHILE p > 0 REP
replace (string, p, new);
p := pos (string, old, p + 1)
PER.
END PROC change all by replace;
PROC control char conversion (TEXT VAR string, INT CONST code type):
IF code type <> transparent
THEN code conversion
FI.
code conversion:
INT VAR p := pos (string, ""0"", ""31"", 1);
WHILE p > 0 REP
convert char;
p := pos (string, ""0"", ""31"", p)
PER.
convert char:
INT CONST char code := code (string SUB p);
SELECT char code OF
CASE tab code: expand tab
CASE lf code: change (string, p, p, "")
CASE ff code: change (string, p, p, page cmd)
CASE cr code: change (string, p, p, "")
OTHERWISE ersatzdarstellung
END SELECT.
expand tab:
change (string, p, p, (8 - (p - 1) MOD 8) * " ").
ersatzdarstellung:
TEXT CONST t := text (char code);
change (string, p, p, "#" + (3 - length (t)) * "0" + t + "#").
END PROC control char conversion;
PROC fetch rowtextmode (DATASPACE VAR file space,
TEXT CONST name):
enable stop;
open fetch dos file (name);
initialize fetch rowtext mode;
WHILE NOT was last fetch cluster REP
cluster struct.size INCR 1;
cluster struct.cluster row [cluster struct.size] := "";
cat next fetch dos cluster (cluster struct.cluster row [cluster struct.size])
PER;
close fetch dos file.
initialize fetch row text mode:
forget (file space);
file space := nilspace;
cluster struct := file space;
type (file space, row text type);
cluster struct.size := 0.
END PROC fetch rowtext mode;
PROC fetch ds mode (DATASPACE VAR in ds, TEXT CONST name):
enable stop;
open fetch dos file (name);
init fetch dsmode;
WHILE NOT was last fetch cluster REP
read next fetch dos cluster (in ds, ds block no);
PER;
close fetch dos file.
init fetch dsmode:
forget (in ds);
in ds := nilspace;
INT VAR ds block no := 2.
END PROC fetch ds mode;
PROC fetch dumpmode (DATASPACE VAR file space, TEXT CONST name):
enable stop;
open fetch dos file (name);
initialize fetch dumpmode;
WHILE NOT was last fetch cluster REP
TEXT VAR cluster buffer := "";
cat next fetch dos cluster (cluster buffer);
dump cluster
UNTIL offset > 50 000.0
PER;
close fetch dos file.
initialize fetch dump mode:
BOOL VAR fertig := FALSE;
REAL VAR offset := 0.0;
forget (file space);
file space := nilspace;
file := sequential file (output, file space).
dump cluster:
TEXT VAR dump line;
INT VAR line, column;
FOR line FROM 0 UPTO (cluster size DIV 16) - 1 REP
build dump line;
putline (file, dump line);
offset INCR 16.0
UNTIL fertig
PER.
build dump line:
TEXT VAR char line := "";
dump line := text (offset, 6, 0);
dump line := subtext (dump line, 1, 5);
dump line CAT " ";
FOR column FROM 0 UPTO 7 REP
convert char;
dump line CAT " "
PER;
dump line CAT " ";
FOR column FROM 8 UPTO 15 REP
convert char;
dump line CAT " "
PER;
dump line CAT " ";
dump line CAT char line.
convert char:
TEXT CONST char :: cluster buffer SUB (line * 16 + column + 1);
IF char = ""
THEN fertig := TRUE;
dump line CAT " ";
LEAVE convert char
FI;
INT CONST char code := code (char);
LET hex chars = "0123456789ABCDEF";
dump line CAT (hex chars SUB (char code DIV 16 + 1));
dump line CAT (hex chars SUB (char code MOD 16 + 1));
charline CAT show char.
show char:
IF (char code > 31 AND char code < 127)
THEN char
ELSE "."
FI.
END PROC fetch dump mode;
PROC check file (TEXT CONST name):
disable stop;
DATASPACE VAR test ds := nilspace;
enable check file (name, test ds);
forget (test ds);
IF is error
THEN clear error;
error stop ("Fehler beim Prüflesen der Datei """ + name + """")
FI.
END PROC check file;
PROC enable check file (TEXT CONST name, DATASPACE VAR test ds):
enable stop;
open fetch dos file (name);
WHILE NOT was last fetch cluster REP
INT VAR dummy := 2;
read next fetch dos cluster (test ds, dummy)
PER;
close fetch dos file.
END PROC enable check file;
END PACKET fetch;