1{
2    This file is part of the Free Pascal run time library.
3    Copyright (c) 1999-2000 by the Free Pascal development team.
4
5    Includefile for objects.pp implementing OS-dependent file routines
6    for WIN32
7
8    See the file COPYING.FPC, included in this distribution,
9    for details about the copyright.
10
11    This program is distributed in the hope that it will be useful,
12    but WITHOUT ANY WARRANTY; without even the implied warranty of
13    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
14
15 **********************************************************************
16}
17
18CONST
19   { REQUIRED TO PUT MANUALLY here, because of name conflicts in win32.inc }
20   { flags for CreateFile }
21   GENERIC_READ=longint($80000000);
22   GENERIC_WRITE=$40000000;
23   CREATE_NEW = 1;
24   CREATE_ALWAYS = 2;
25   OPEN_EXISTING = 3;
26   OPEN_ALWAYS = 4;
27   TRUNCATE_EXISTING = 5;
28
29   FILE_ATTRIBUTE_ARCHIVE = 32;
30   FILE_ATTRIBUTE_COMPRESSED = 2048;
31   FILE_ATTRIBUTE_NORMAL = 128;
32   FILE_ATTRIBUTE_DIRECTORY = 16;
33   FILE_ATTRIBUTE_HIDDEN = 2;
34   FILE_ATTRIBUTE_READONLY = 1;
35   FILE_ATTRIBUTE_SYSTEM = 4;
36   FILE_ATTRIBUTE_TEMPORARY = 256;
37
38   { flags for SetFilePos }
39   FILE_BEGIN = 0;
40   FILE_CURRENT = 1;
41   FILE_END = 2;
42
43   { misc. functions }
44   function GetLastError : DWORD;
45     stdcall;external 'kernel32' name 'GetLastError';
46
47   function WriteFile(fh:longint;buf:pointer;len:longint;var loaded:longint;
48     overlap:pointer):longint;
49     stdcall;external 'kernel32' name 'WriteFile';
50   function ReadFile(fh:longint;buf:pointer;len:longint;var loaded:longint;
51     overlap:pointer):longint;
52     stdcall;external 'kernel32' name 'ReadFile';
53   function CloseHandle(h : longint) : longint;
54     stdcall;external 'kernel32' name 'CloseHandle';
55   function DeleteFile(p : pchar) : longint;
56     stdcall;external 'kernel32' name 'DeleteFileA';
57   function MoveFile(old,_new : pchar) : longint;
58     stdcall;external 'kernel32' name 'MoveFileA';
59   function SetFilePointer(l1,l2 : longint;l3 : pointer;l4 : longint) : longint;
60     stdcall;external 'kernel32' name 'SetFilePointer';
61   function GetFileSize(h:longint;p:pointer) : longint;
62     stdcall;external 'kernel32' name 'GetFileSize';
63   function CreateFile(name : pointer;access,sharing : longint;
64     security : pointer;how,attr,template : longint) : longint;
65     stdcall;external 'kernel32' name 'CreateFileA';
66   function SetEndOfFile(h : longint) : boolean;
67     stdcall;external 'kernel32' name 'SetEndOfFile';
68   function GetFileType(Handle:DWORD):DWord;
69     stdcall;external 'kernel32' name 'GetFileType';
70
71
72{---------------------------------------------------------------------------}
73{  FileClose -> Platforms WIN32            - Not checked                    }
74{---------------------------------------------------------------------------}
75FUNCTION FileClose(Handle: THandle): word;
76begin
77   closehandle(handle);
78   FileClose := 0;
79end;
80
81{---------------------------------------------------------------------------}
82{  FileOpen -> Platforms WIN32            - Tested MVC                      }
83{  Returns 0 on failure                                                     }
84{---------------------------------------------------------------------------}
85
86FUNCTION FileOpen (Var FileName: AsciiZ; Mode: Word): THandle;
87var
88 oflags,cd: longint;
89 AHandle : longint;
90begin
91  { On opening reset error code }
92  DosStreamError := 0;
93  if Mode=stCreate then
94    Begin
95      cd:=CREATE_ALWAYS;
96      oflags:=GENERIC_WRITE or GENERIC_READ;
97    End
98  else
99    Begin
100      cd:=OPEN_EXISTING;
101      { convert filemode to filerec modes }
102      case (Mode and 3) of
103        0 : oflags:=GENERIC_READ;
104        1 : oflags:=GENERIC_WRITE;
105        2 : oflags:=GENERIC_WRITE or GENERIC_READ;
106      end;
107     end;
108   AHandle:=CreateFile(pointer(@FileName),oflags,0,nil,cd,FILE_ATTRIBUTE_NORMAL,0);
109   if AHandle = -1 then
110     begin
111     FileOpen:=0;
112     DosStreamError:=word(GetLastError);
113     end
114   else
115     FileOpen := AHandle;
116end;
117
118
119{***************************************************************************}
120{  DosSetFilePtr -> Platforms WIN32        - Tested MVC                     }
121{***************************************************************************}
122FUNCTION SetFilePos (Handle: THandle; Pos: LongInt; MoveType: Word;
123Var Actual: LongInt): Word;
124BEGIN
125  { WARNING WIN32 CURRECTLY HAS THE SAME SEEK MODE AS MSDOS    }
126  { if this changes don't forget to change and check the flags }
127  { accordingly.                                               }
128  Actual:=SetFilePointer(handle,pos,nil,MoveType);
129  If Actual=-1 then
130    DosStreamError:=word(GetLastError);
131  SetFilePos := DosStreamError;                   { Return any error }
132END;
133
134
135{---------------------------------------------------------------------------}
136{  FileRead -> Platforms WIN32            - Tested MVC                      }
137{---------------------------------------------------------------------------}
138FUNCTION FileRead (Handle: THandle; Var Buf; Count: Sw_Word;
139Var Actual: Sw_Word): Word;
140
141Var res : longint;
142
143BEGIN
144  res:=0;
145  if readfile(handle,pointer(@buf),count,res,nil)=0 then
146     DosStreamError:=word(GetLastError);
147  Actual:=res;
148  FileRead:=DosStreamError;
149end;
150
151
152{---------------------------------------------------------------------------}
153{  FileWrite -> Platforms WIN32            - Not Checked                    }
154{---------------------------------------------------------------------------}
155FUNCTION FileWrite (Handle: THandle; Var Buf; Count: Sw_Word; Var Actual: Sw_Word): Word;
156BEGIN
157   if writefile(handle,pointer(@buf),count,longint(Actual),nil)=0 then
158    Begin
159      DosStreamError:=word(GetLasterror);
160    end;
161   FileWrite:=DosStreamError;
162end;
163
164
165{---------------------------------------------------------------------------}
166{  SetFileSize -> Platforms DOS          - Not Checked                      }
167{---------------------------------------------------------------------------}
168FUNCTION SetFileSize (Handle: THandle; FileSize: LongInt): Word;
169VAR Actual : Sw_word;
170    Buf: LongInt;
171BEGIN
172   SetFilePos(Handle,FileSize,0,longint(Actual));
173   If (Actual = FileSize) Then
174    Begin
175      Actual := FileWrite(Handle, Buf, 0,Actual);   { Truncate the file }
176      If (Actual <> longword(-1)) Then
177       SetFileSize := 0
178      Else
179       SetFileSize := 103;                            { File truncate error }
180    End
181   Else
182    SetFileSize := 103;                       { File truncate error }
183END;
184
185