summaryrefslogtreecommitdiff
path: root/system/dos/1986/src/fetch
blob: ad00ab6fea0e0a415cfbc828278afeb5699c5ee5 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
PACKET fetch DEFINES                   (* Copyright (C) 1985 *)
                                       (* Frank Klapper      *)
                                       (* 07.05.86           *) 
  fetch filemode, 
  fetch rowtextmode,
  fetch dsmode, 
  check file:

LET       ascii        = 1,
          ascii german = 2,
          transparent  = 3,
          ebcdic       = 4,
          atari st     = 10;

LET row text mode length = 4000,
    row text type        = 1000,

    ctrl z         = ""26"", 
    tab            = ""9"",
    page cmd       = "#page#";

CLUSTER VAR cluster;

DATASPACE VAR cluster space;

BOUND STRUCT (INT size,
              ROW row text mode length TEXT cluster row) VAR cluster struct;

INT VAR next cluster no;
REAL VAR file rest;

FILE VAR file;

PROC fetch filemode (DATASPACE VAR file space, 
                     TEXT CONST name, INT CONST code type):
  disable stop;
  cluster space := nilspace;
  cluster := cluster space;
  enabled fetch filemode (file space, name, code type);
  forget (cluster space).
 
END PROC fetch filemode; 
 
PROC enabled fetch filemode (DATASPACE VAR file space, 
                             TEXT CONST name,
                             INT CONST code type):
  enable stop;
  initialize fetch filemode;
  open fetch (name, file rest, next cluster no);
  WHILE (next cluster no >= 0) AND (file rest > 0.0) REP
    get text of act cluster;
    write lines;
(***************************************)
    IF lines (file) > 3950
      THEN putline (file, ">>> FREMDDATEI FUER EUMEL ZU LANG. ES K™NNEN DATEN FEHLEN <<<");
           LEAVE enabled fetch filemode
    FI;
(***************************************)
  PER;
  write last line if necessary. 
 
initialize fetch filemode:
  REAL VAR real cluster size := real (cluster size);
  TEXT VAR buffer := "";
  forget (file space);
  file space := nilspace;
  file := sequential file (output, file space);
  init cr lf ff const.
 
init cr lf ff const:
  TEXT VAR cr, lf, ff;
  SELECT codetype OF 
    CASE ascii, ascii german, atari st: cr := ""13""; lf := ""10""; ff := ""12""
    CASE transparent: cr := ""13""; lf := ""10""; ff := ""12""
    CASE ebcdic: cr := ""13""; lf := "%"; ff := ""12""
  END SELECT;
  TEXT CONST select buffer := cr + lf + ff;
  TEXT CONST min line end char := code (min (code (cr), min (code (lf), code (ff)))),
             max line end char := code (max (code (cr), max (code (lf), code (ff)))).

get text of act cluster:
  fetch next cluster (cluster space, first non dummy ds page);
  buffer CAT text (cluster, 1, valid buffer length);
  file rest DECR real cluster size;
  IF seven bit code
    THEN cancel bit 8
  FI;
  IF ctrl z end
    THEN test ctrl z
  FI;
  INT CONST bufferlength := LENGTH buffer.

ctrl z end:
  (code type = ascii) OR (code type = ascii german).

seven bit code:
  code type = ascii OR code type = ascii german.

valid buffer length:
  int (min (file rest, real cluster size)).

cancel bit 8:
  INT VAR set pos := pos (buffer, "€", ""255"", 1);
  WHILE set pos > 0 REP
    replace (buffer, set pos, seven bit char);
    set pos := pos (buffer, "€", ""255"", set pos + 1)
  PER.

seven bit char:
  code (code (buffer SUB set pos) AND 127).

test ctrl z:
  IF pos (buffer, ctrl z) > 0
    THEN file rest := 0.0;
         buffer := subtext (buffer, 1, pos (buffer, ctrl z) - 1)
  FI.

write lines:
  INT VAR begin pos := 1, end pos;
  next cr lf ff pos;
  WHILE end pos > 0 REP
    execute char and get new pos pointer;
    next cr lf ff pos
  PER;
  compress buffer.

next cr lf ff pos:
  end pos := pos (buffer, min line end char, max line end char, begin pos);
  WHILE no line end char REP
    end pos := pos (buffer, min line end char, max line end char, end pos + 1)
  PER.

no line end char:
  (end pos > 0) AND (pos (select buffer, buffer SUB end pos) = 0).

compress buffer:
  buffer := subtext (buffer, begin pos).

execute char and get new pos pointer:
  SELECT pos (select buffer, buffer SUB end pos) OF
    CASE 1: execute cr
    CASE 2: execute lf
    CASE 3: execute ff
  END SELECT.

execute cr: 
  IF (end pos = bufferlength) AND (file rest > 0.0)
    THEN compress buffer;
         LEAVE write lines
  FI;
  write line (subtext (buffer, begin pos, end pos - 1), code type);
  IF (buffer SUB (end pos + 1)) = lf 
    THEN begin pos := end pos + 2
    ELSE begin pos := end pos + 1
  FI.
 
execute ff:
  write line (subtext (buffer, begin pos, end pos - 1), code type);
  putline (file, page cmd);
  begin pos := end pos + 1.

execute lf: 
  IF (end pos = bufferlength) AND (file rest > 0.0)
    THEN compress buffer;
         LEAVE write lines
  FI;
  write line (subtext (buffer, begin pos, end pos - 1), code type);
  IF (buffer SUB (end pos + 1)) = cr 
    THEN begin pos := end pos + 2
    ELSE begin pos := end pos + 1
  FI.
 
write last line if necessary:
  IF buffer <> ""
    THEN end pos := LENGTH buffer + 1;
         write line (subtext (buffer, begin pos, end pos - 1), code type)
  FI.

END PROC enabled fetch filemode;

PROC write line (TEXT CONST line, INT CONST code type):
  TEXT VAR result;
  SELECT code type OF
    CASE ascii: ascii conversion
    CASE ascii german: ascii german conversion
    CASE atari st: atari st conversion
    CASE transparent: putline (file, line)
    CASE ebcdic: ebcdic conversion
  END SELECT.

ascii conversion:
  expand tabs;
  replace steuerzeichen;
  putline (file, result).

ascii german conversion:
  expand tabs;
  replace steuerzeichen;
  replace ascii german umlaute;
  putline (file, result).

atari st conversion:
  expand tabs;
  replace steuerzeichen;
  replace atari st umlaute;
  putline (file, result).

replace ascii german umlaute:
  change all (result, "[", "Ž");
  change all (result, "\", "™");
  change all (result, "]", "š");
  change all (result, "{", "„");
  change all (result, "|", "”");
  change all (result, "}", "");
  change all (result, "~", "α").

replace atari st umlaute:
  change all (result, ""142"", "Ž");
  change all (result, ""153"", "™");
  change all (result, ""154"", "š");
  change all (result, ""132"", "„");
  change all (result, ""148"", "”");
  change all (result, ""129"", "");
  change all (result, ""158"", "α").

expand tabs:
  result := line;
  INT VAR tab pos := pos (result, tab);
  WHILE tab pos > 0 REP
    expand tab;
    tab pos := pos (result, tab)
  PER.

expand tab:
  result := subtext (result, 1, tab pos - 1) + (8 - ((tab pos - 1)) MOD 8) * " "
          + subtext (result, tab pos + 1).

replace steuerzeichen:
  INT VAR position := pos (result, ""0"", ""31"", 1);
  WHILE position > 0 REP
    TEXT VAR char := result SUB position;
    change all (result, char, "#" + int code + "#");
    position := pos (result, ""0"", ""31"", position)
  PER.

ebcdic conversion:
  result := line;
  ebcdic to eumel with substitution (result);
  putline (file, result).
 
int code: 
  (3 - LENGTH text (code (char))) * "0" + text (code (char)).

END PROC write line;

PROC fetch rowtextmode (DATASPACE VAR file space,
                        TEXT CONST name):
  disable stop;
  cluster space := nilspace;
  cluster := cluster space;
  enabled fetch rowtextmode (file space, name);
  forget (cluster space).
 
END PROC fetch rowtextmode;
 
PROC enabled fetch rowtextmode (DATASPACE VAR file space,
                               TEXT CONST name):
  enable stop; 
  open fetch (name, file rest, next cluster no);
  initialize fetch rowtext mode;
  WHILE next cluster no >= 0 REP
    fetch next cluster (cluster space, first non dummy ds page);
    cluster struct.size INCR 1;
    IF file rest < real cluster size
     THEN cluster struct.cluster row [cluster struct.size]
                         := text (cluster, 1, int (file rest));
          file rest := 0.0
     ELSE cluster struct.cluster row [cluster struct.size] := text (cluster, 1, cluster size); 
          file rest DECR real cluster size
     FI
  PER. 
 
initialize fetch row text mode:
  forget (file space);
  file space := nilspace;
  cluster struct := file space;
  type (file space, row text type);
  REAL VAR real cluster size := real (cluster size);
  cluster struct.size := 0.

END PROC enabled fetch rowtext mode;

PROC fetch ds mode (DATASPACE VAR ds, TEXT CONST name):
  enable stop;
  open fetch (name, file rest, next cluster no);
  init fetch dsmode;
  WHILE next cluster no >= 0 REP
    fetch next cluster (ds, ds block no);
     ds block no INCR sectors per cluster;
  PER. 
 
init fetch dsmode:
  forget (ds);
  ds := nilspace;
  INT VAR ds block no := 2.

END PROC fetch ds mode;

PROC check file (TEXT CONST name):
  disable stop;
  cluster space := nilspace;
  cluster := cluster space;
  enabled check file (name);
  forget (cluster space).
 
END PROC check file;
 
PROC enabled check file (TEXT CONST name):
  enable stop;
  open fetch (name, file rest, next cluster no);
  WHILE next cluster no >= 0 REP
    fetch next cluster (cluster space, first non dummy ds page)
  PER. 
 
END PROC enabled check file;

PROC fetch next cluster (DATASPACE VAR fetch space, INT CONST first page):
  read disk cluster (fetch space, first page, next cluster no);
  next cluster no := next fetch cluster no.

END PROC fetch next cluster;

END PACKET fetch;