file7.pas
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
{$A+,B+,D-,E+,F+,I+,L+,N-,O+,R-,S+,V-}
unit file7;
interface
uses
crt,dos,
{rcg11172000 no overlay under Linux.}
{overlay,}
file0,
common;
procedure recvascii(fn:astr; var dok:boolean; tpb:real);
procedure sendascii(fn:astr);
implementation
procedure recvascii(fn:astr; var dok:boolean; tpb:real);
var f:file;
r1:array[0..1023] of byte;
byte_count,start_time:longint;
bytes_this_line,kbyte_count,line_count:integer;
b:byte;
start,abort,error,done,timeo,kba,prompti:boolean;
c:char;
(* procedure onec(var b:byte);
var r:real;
i:byte;
c:char;
bb:boolean;
begin
if (inhead[modemr.comport]<>intail[modemr.comport]) then begin
bb:=recom1(c);
b:=ord(c);
end else begin
r:=timer;
while (not async_buffer_check) and (tchk(r,90.0)) do checkhangup;
if (async_buffer_check) then b:=ord(ccinkey1)
else begin
timeo:=TRUE;
b:=0;
end;
if (timeo) then error:=TRUE;
if (hangup) then begin
error:=TRUE; done:=TRUE;
abort:=TRUE;
end;
end;
end;*)
procedure checkkb;
var c:char;
begin
if (keypressed) then begin
c:=readkey;
if (c=#27) then begin
abort:=TRUE; done:=TRUE; kba:=TRUE;
nl; star('Aborted.');
end;
end;
end;
begin
abort:=FALSE; done:=FALSE; timeo:=FALSE; kba:=FALSE;
line_count:=0; start:=FALSE;
start_time:=trunc(timer); byte_count:=0;
assign(f,fn);
{$I-} rewrite(f,1); {$I+}
if (ioresult<>0) then begin
if (useron) then star('Disk error - sorry, unable to upload it.');
done:=TRUE; abort:=TRUE;
end;
prompti:=pynq('Do you want prompted input?');
if (useron) then star('Upload Ascii text. Press Ctrl-Z (^Z) when done');
while (not done) and (not hangup) do begin
error:=TRUE;
checkkb;
if (kba) then begin
done:=TRUE;
abort:=TRUE;
end;
if (not kba) then
if (prompti) then begin
com_flush_rx;
sendcom1('>');
end;
if (not done) and (not abort) and (not hangup) then begin
start:=FALSE;
error:=FALSE;
checkkb;
if (not done) then begin
bytes_this_line:=0;
repeat
getkey(c); b:=ord(c);
if (b=26) then begin
start:=TRUE; done:=TRUE;
nl;
if (useron) then star('End Of File Received');
end else begin
if (b<>10) then begin (* ignore LF *)
r1[bytes_this_line]:=b;
bytes_this_line:=bytes_this_line+1;
end;
end;
until (bytes_this_line>250) or (b=13) or (timeo) or (done);
if (b<>13) then begin
r1[bytes_this_line]:=13;
bytes_this_line:=bytes_this_line+1;
end;
r1[bytes_this_line]:=10;
bytes_this_line:=bytes_this_line+1;
seek(f,byte_count);
{$I-} blockwrite(f,r1,bytes_this_line); {$I+}
if (ioresult<>0) then begin
nl;
if (useron) then star('Disk error');
done:=TRUE; abort:=TRUE;
end;
inc(line_count);
byte_count:=byte_count+bytes_this_line;
end;
end;
end;
close(f);
kbyte_count:=0;
while (byte_count>1024) do begin
inc(kbyte_count);
byte_count:=byte_count-1024;
end;
if (byte_count>512) then inc(kbyte_count,1);
if (hangup) then abort:=TRUE;
if (abort) then erase(f)
else begin
star(cstr(line_count)+' lines, '+cstr(kbyte_count)+'k uploaded');
if (timer<start_time) then start_time:=start_time-24*60*60;
end;
dok:=not abort;
end;
procedure sendascii(fn:astr);
var f:file of char;
i:integer;
c,c1:char;
abort:boolean;
procedure ckey;
begin
checkhangup;
while (not empty) and (not abort) and (not hangup) do begin
if (hangup) then abort:=TRUE;
c1:=inkey;
if (c1=^X) or (c1=#27) or (c1=' ') then abort:=TRUE;
if (c1=^S) then getkey(c1);
end;
end;
begin
assign(f,fn);
{$I-} reset(f); {$I+}
if (ioresult<>0) then print('File not found.') else begin
abort:=FALSE;
print('^X = Abort -- ^S = Pause');
print('Press <CR> to start ... '); nl;
repeat getkey(c) until (c=^M) or (hangup);
while (not hangup) and (not abort) and (not eof(f)) do begin
read(f,c); if (outcom) then sendcom1(c);
if (c<>^G) then write(c);
ckey;
end;
close(f);
prompt(^Z);
nl; nl;
star('File transmission complete.');
end;
end;
end.