1   { Keep Track of open files }
2   const
3      max_files = 50;
4   var
5      openfiles : array [0..max_files-1] of boolean;
6{$ifdef SYSTEMDEBUG}
7      opennames : array [0..max_files-1] of pchar;
8   const
9      free_closed_names : boolean = true;
10{$endif SYSTEMDEBUG}
11
12{****************************************************************************
13                        Low level File Routines
14 ****************************************************************************}
15
16procedure do_close(handle : longint);
17var
18  regs : trealregs;
19begin
20  if Handle<=4 then
21   exit;
22  regs.realebx:=handle;
23  if handle<max_files then
24    begin
25       openfiles[handle]:=false;
26{$ifdef SYSTEMDEBUG}
27       if assigned(opennames[handle]) and free_closed_names then
28         begin
29            sysfreememsize(opennames[handle],strlen(opennames[handle])+1);
30            opennames[handle]:=nil;
31         end;
32{$endif SYSTEMDEBUG}
33    end;
34  regs.realeax:=$3e00;
35  sysrealintr($21,regs);
36  if (regs.realflags and carryflag) <> 0 then
37   GetInOutRes(lo(regs.realeax));
38end;
39
40procedure do_erase(p : pchar; pchangeable: boolean);
41var
42  regs : trealregs;
43  oldp : pchar;
44begin
45  oldp:=p;
46  DoDirSeparators(p,pchangeable);
47  syscopytodos(longint(p),strlen(p)+1);
48  regs.realedx:=tb_offset;
49  regs.realds:=tb_segment;
50  if LFNSupport then
51   regs.realeax:=$7141
52  else
53   regs.realeax:=$4100;
54  regs.realesi:=0;
55  regs.realecx:=0;
56  sysrealintr($21,regs);
57  if (regs.realflags and carryflag) <> 0 then
58   GetInOutRes(lo(regs.realeax));
59  if p<>oldp then
60    freemem(p);
61end;
62
63procedure do_rename(p1,p2 : pchar; p1changeable, p2changeable: boolean);
64var
65  regs : trealregs;
66  oldp1, oldp2 : pchar;
67begin
68  oldp1:=p1;
69  oldp2:=p2;
70  DoDirSeparators(p1,p1changeable);
71  DoDirSeparators(p2,p2changeable);
72  if strlen(p1)+strlen(p2)+3>tb_size then
73   HandleError(217);
74  sysseg_move(get_ds,sizeuint(p2),dos_selector,tb,strlen(p2)+1);
75  sysseg_move(get_ds,sizeuint(p1),dos_selector,tb+strlen(p2)+2,strlen(p1)+1);
76  regs.realedi:=tb_offset;
77  regs.realedx:=tb_offset + strlen(p2)+2;
78  regs.realds:=tb_segment;
79  regs.reales:=tb_segment;
80  if LFNSupport then
81   regs.realeax:=$7156
82  else
83   regs.realeax:=$5600;
84  regs.realecx:=$ff;            { attribute problem here ! }
85  sysrealintr($21,regs);
86  if (regs.realflags and carryflag) <> 0 then
87   GetInOutRes(lo(regs.realeax));
88  if p1<>oldp1 then
89    freemem(p1);
90  if p2<>oldp2 then
91    freemem(p2);
92end;
93
94function do_write(h:longint;addr:pointer;len : longint) : longint;
95var
96  regs      : trealregs;
97  size,
98  writesize : longint;
99begin
100  writesize:=0;
101  while len > 0 do
102   begin
103     if len>tb_size then
104      size:=tb_size
105     else
106      size:=len;
107     syscopytodos(ptrint(addr)+writesize,size);
108     regs.realecx:=size;
109     regs.realedx:=tb_offset;
110     regs.realds:=tb_segment;
111     regs.realebx:=h;
112     regs.realeax:=$4000;
113     sysrealintr($21,regs);
114     if (regs.realflags and carryflag) <> 0 then
115      begin
116        GetInOutRes(lo(regs.realeax));
117        exit(writesize);
118      end;
119     inc(writesize,lo(regs.realeax));
120     dec(len,lo(regs.realeax));
121     { stop when not the specified size is written }
122     if lo(regs.realeax)<size then
123      break;
124   end;
125  Do_Write:=WriteSize;
126end;
127
128function do_read(h:longint;addr:pointer;len : longint) : longint;
129var
130  regs     : trealregs;
131  size,
132  readsize : longint;
133begin
134  readsize:=0;
135  while len > 0 do
136   begin
137     if len>tb_size then
138      size:=tb_size
139     else
140      size:=len;
141     regs.realecx:=size;
142     regs.realedx:=tb_offset;
143     regs.realds:=tb_segment;
144     regs.realebx:=h;
145     regs.realeax:=$3f00;
146     sysrealintr($21,regs);
147     if (regs.realflags and carryflag) <> 0 then
148      begin
149        GetInOutRes(lo(regs.realeax));
150        do_read:=0;
151        exit;
152      end;
153     syscopyfromdos(ptrint(addr)+readsize,lo(regs.realeax));
154     inc(readsize,lo(regs.realeax));
155     dec(len,lo(regs.realeax));
156     { stop when not the specified size is read }
157     if lo(regs.realeax)<size then
158      break;
159   end;
160  do_read:=readsize;
161end;
162
163
164function do_filepos(handle : longint) : longint;
165var
166  regs : trealregs;
167begin
168  regs.realebx:=handle;
169  regs.realecx:=0;
170  regs.realedx:=0;
171  regs.realeax:=$4201;
172  sysrealintr($21,regs);
173  if (regs.realflags and carryflag) <> 0 then
174   Begin
175     GetInOutRes(lo(regs.realeax));
176     do_filepos:=0;
177   end
178  else
179   do_filepos:=lo(regs.realedx) shl 16+lo(regs.realeax);
180end;
181
182
183procedure do_seek(handle,pos : longint);
184var
185  regs : trealregs;
186begin
187  regs.realebx:=handle;
188  regs.realecx:=pos shr 16;
189  regs.realedx:=pos and $ffff;
190  regs.realeax:=$4200;
191  sysrealintr($21,regs);
192  if (regs.realflags and carryflag) <> 0 then
193   GetInOutRes(lo(regs.realeax));
194end;
195
196
197
198function do_seekend(handle:longint):longint;
199var
200  regs : trealregs;
201begin
202  regs.realebx:=handle;
203  regs.realecx:=0;
204  regs.realedx:=0;
205  regs.realeax:=$4202;
206  sysrealintr($21,regs);
207  if (regs.realflags and carryflag) <> 0 then
208   Begin
209     GetInOutRes(lo(regs.realeax));
210     do_seekend:=0;
211   end
212  else
213   do_seekend:=lo(regs.realedx) shl 16+lo(regs.realeax);
214end;
215
216
217function do_filesize(handle : longint) : longint;
218var
219  aktfilepos : longint;
220begin
221  aktfilepos:=do_filepos(handle);
222  do_filesize:=do_seekend(handle);
223  do_seek(handle,aktfilepos);
224end;
225
226
227{ truncate at a given position }
228procedure do_truncate (handle,pos:longint);
229var
230  regs : trealregs;
231begin
232  do_seek(handle,pos);
233  regs.realecx:=0;
234  regs.realedx:=tb_offset;
235  regs.realds:=tb_segment;
236  regs.realebx:=handle;
237  regs.realeax:=$4000;
238  sysrealintr($21,regs);
239  if (regs.realflags and carryflag) <> 0 then
240   GetInOutRes(lo(regs.realeax));
241end;
242
243const
244  FileHandleCount : longint = 20;
245
246function Increase_file_handle_count : boolean;
247var
248  regs : trealregs;
249begin
250  Inc(FileHandleCount,10);
251  regs.realebx:=FileHandleCount;
252  regs.realeax:=$6700;
253  sysrealintr($21,regs);
254  if (regs.realflags and carryflag) <> 0 then
255   begin
256    Increase_file_handle_count:=false;
257    Dec (FileHandleCount, 10);
258   end
259  else
260    Increase_file_handle_count:=true;
261end;
262
263
264function dos_version : word;
265var
266  regs   : trealregs;
267begin
268  regs.realeax := $3000;
269  sysrealintr($21,regs);
270  dos_version := regs.realeax
271end;
272
273
274procedure do_open(var f;p:pchar;flags:longint; pchangeable: boolean);
275{
276  filerec and textrec have both handle and mode as the first items so
277  they could use the same routine for opening/creating.
278  when (flags and $100)   the file will be append
279  when (flags and $1000)  the file will be truncate/rewritten
280  when (flags and $10000) there is no check for close (needed for textfiles)
281}
282var
283  regs   : trealregs;
284  action : longint;
285  Avoid6c00 : boolean;
286  oldp : pchar;
287begin
288{ check if Extended Open/Create API is safe to use }
289  Avoid6c00 := lo(dos_version) < 7;
290{ close first if opened }
291  if ((flags and $10000)=0) then
292   begin
293     case filerec(f).mode of
294      fminput,fmoutput,fminout : Do_Close(filerec(f).handle);
295      fmclosed : ;
296     else
297      begin
298        inoutres:=102; {not assigned}
299        exit;
300      end;
301     end;
302   end;
303{ reset file handle }
304  filerec(f).handle:=UnusedHandle;
305  action:=$1;
306{ convert filemode to filerec modes }
307  case (flags and 3) of
308   0 : filerec(f).mode:=fminput;
309   1 : filerec(f).mode:=fmoutput;
310   2 : filerec(f).mode:=fminout;
311  end;
312  if (flags and $1000)<>0 then
313   action:=$12; {create file function}
314{ empty name is special }
315  if p[0]=#0 then
316   begin
317     case FileRec(f).mode of
318       fminput :
319         FileRec(f).Handle:=StdInputHandle;
320       fminout, { this is set by rewrite }
321       fmoutput :
322         FileRec(f).Handle:=StdOutputHandle;
323       fmappend :
324         begin
325           FileRec(f).Handle:=StdOutputHandle;
326           FileRec(f).mode:=fmoutput; {fool fmappend}
327         end;
328     end;
329     exit;
330   end;
331  oldp:=p;
332  DoDirSeparators(p,pchangeable);
333{ real dos call }
334  syscopytodos(longint(p),strlen(p)+1);
335{$ifndef RTLLITE}
336  if LFNSupport then
337   regs.realeax := $716c                           { Use LFN Open/Create API }
338  else
339   regs.realeax:=$6c00;
340{$endif RTLLITE}
341   if Avoid6c00 then
342     regs.realeax := $3d00 + (flags and $ff)      { For now, map to Open API }
343   else
344     regs.realeax := $6c00;                   { Use Extended Open/Create API }
345  if byte(regs.realeax shr 8) = $3d then
346    begin  { Using the older Open or Create API's }
347      if (action and $00f0) <> 0 then
348        regs.realeax := $3c00;                   { Map to Create/Replace API }
349      regs.realds := tb_segment;
350      regs.realedx := tb_offset;
351    end
352  else
353    begin  { Using LFN or Extended Open/Create API }
354      regs.realedx := action;            { action if file does/doesn't exist }
355      regs.realds := tb_segment;
356      regs.realesi := tb_offset;
357      regs.realebx := $2000 + (flags and $ff);              { file open mode }
358    end;
359  regs.realecx := $20;                                     { file attributes }
360  sysrealintr($21,regs);
361{$ifndef RTLLITE}
362  if (regs.realflags and carryflag) <> 0 then
363    if lo(regs.realeax)=4 then
364      if Increase_file_handle_count then
365        begin
366          { Try again }
367          if LFNSupport then
368            regs.realeax := $716c                    {Use LFN Open/Create API}
369          else
370            if Avoid6c00 then
371              regs.realeax := $3d00+(flags and $ff) {For now, map to Open API}
372            else
373              regs.realeax := $6c00;            {Use Extended Open/Create API}
374          if byte(regs.realeax shr 8) = $3d then
375            begin  { Using the older Open or Create API's }
376              if (action and $00f0) <> 0 then
377                regs.realeax := $3c00;             {Map to Create/Replace API}
378              regs.realds := tb_segment;
379              regs.realedx := tb_offset;
380            end
381          else
382            begin  { Using LFN or Extended Open/Create API }
383              regs.realedx := action;      {action if file does/doesn't exist}
384              regs.realds := tb_segment;
385              regs.realesi := tb_offset;
386              regs.realebx := $2000+(flags and $ff);          {file open mode}
387            end;
388          regs.realecx := $20;                               {file attributes}
389          sysrealintr($21,regs);
390        end;
391{$endif RTLLITE}
392  if (regs.realflags and carryflag) <> 0 then
393    begin
394      GetInOutRes(lo(regs.realeax));
395      FileRec(f).mode:=fmclosed;
396      if oldp<>p then
397        freemem(p);
398      exit;
399    end
400  else
401    begin
402      filerec(f).handle:=lo(regs.realeax);
403{$ifndef RTLLITE}
404      { for systems that have more then 20 by default ! }
405      if lo(regs.realeax)>FileHandleCount then
406        FileHandleCount:=lo(regs.realeax);
407{$endif RTLLITE}
408    end;
409  if lo(regs.realeax)<max_files then
410    begin
411{$ifdef SYSTEMDEBUG}
412       if openfiles[lo(regs.realeax)] and
413          assigned(opennames[lo(regs.realeax)]) then
414         begin
415            Writeln(stderr,'file ',opennames[lo(regs.realeax)],'(',lo(regs.realeax),') not closed but handle reused!');
416            sysfreememsize(opennames[lo(regs.realeax)],strlen(opennames[lo(regs.realeax)])+1);
417         end;
418{$endif SYSTEMDEBUG}
419       openfiles[lo(regs.realeax)]:=true;
420{$ifdef SYSTEMDEBUG}
421       opennames[lo(regs.realeax)] := sysgetmem(strlen(p)+1);
422       move(p^,opennames[lo(regs.realeax)]^,strlen(p)+1);
423{$endif SYSTEMDEBUG}
424    end;
425{ append mode }
426  if ((flags and $100) <> 0) and
427   (FileRec (F).Handle <> UnusedHandle) then
428   begin
429     do_seekend(filerec(f).handle);
430     filerec(f).mode:=fmoutput; {fool fmappend}
431   end;
432  if oldp<>p then
433    freemem(p);
434end;
435
436function do_isdevice(handle:THandle):boolean;
437var
438  regs : trealregs;
439begin
440  regs.realebx:=handle;
441  regs.realeax:=$4400;
442  sysrealintr($21,regs);
443  do_isdevice:=(regs.realedx and $80)<>0;
444  if (regs.realflags and carryflag) <> 0 then
445   GetInOutRes(lo(regs.realeax));
446end;
447
448