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