diff options
Diffstat (limited to 'system/dos/1.8.7/src/fetch')
| -rw-r--r-- | system/dos/1.8.7/src/fetch | 371 |
1 files changed, 371 insertions, 0 deletions
diff --git a/system/dos/1.8.7/src/fetch b/system/dos/1.8.7/src/fetch new file mode 100644 index 0000000..7cb7571 --- /dev/null +++ b/system/dos/1.8.7/src/fetch @@ -0,0 +1,371 @@ +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; + |