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