fpc/rtl/os2/sysutils.pp
2001-10-25 21:23:49 +00:00

828 lines
19 KiB
ObjectPascal

{
$Id$
This file is part of the Free Pascal run time library.
Copyright (c) 1999-2000 by Florian Klaempfl
member of the Free Pascal development team
Sysutils unit for OS/2
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
**********************************************************************}
unit sysutils;
interface
{$MODE objfpc}
{ force ansistrings }
{$H+}
uses
doscalls,dos;
{ Include platform independent interface part }
{$i sysutilh.inc}
implementation
{ Include platform independent implementation part }
{$i sysutils.inc}
{****************************************************************************
File Functions
****************************************************************************}
{This is the correct way to call external assembler procedures.}
procedure syscall;external name '___SYSCALL';
const
ofRead = $0000; {Open for reading}
ofWrite = $0001; {Open for writing}
ofReadWrite = $0002; {Open for reading/writing}
doDenyRW = $0010; {DenyAll (no sharing)}
faCreateNew = $00010000; {Create if file does not exist}
faOpenReplace = $00040000; {Truncate if file exists}
faCreate = $00050000; {Create if file does not exist, truncate otherwise}
{$ASMMODE INTEL}
function FileOpen (const FileName: string; Mode: integer): longint;
{$IFOPT H+}
assembler;
{$ELSE}
var FN: string;
begin
FN := FileName + #0;
{$ENDIF}
asm
mov eax, Mode
(* DenyAll if sharing not specified. *)
test eax, 112
jnz @FOpen1
or eax, 16
@FOpen1:
mov ecx, eax
mov eax, 7F2Bh
{$IFOPT H+}
mov edx, FileName
{$ELSE}
lea edx, FN
inc edx
{$ENDIF}
call syscall
{$IFOPT H-}
mov [ebp - 4], eax
end;
{$ENDIF}
end;
function FileCreate (const FileName: string): longint;
{$IFOPT H+}
assembler;
{$ELSE}
var FN: string;
begin
FN := FileName + #0;
{$ENDIF}
asm
mov eax, 7F2Bh
mov ecx, ofReadWrite or faCreate or doDenyRW (* Sharing to DenyAll *)
{$IFOPT H+}
mov edx, FileName
{$ELSE}
lea edx, FN
inc edx
{$ENDIF}
call syscall
{$IFOPT H-}
mov [ebp - 4], eax
end;
{$ENDIF}
end;
function FileRead (Handle: longint; var Buffer; Count: longint): longint;
assembler;
asm
mov eax, 3F00h
mov ebx, Handle
mov ecx, Count
mov edx, Buffer
call syscall
jnc @FReadEnd
mov eax, -1
@FReadEnd:
end;
function FileWrite (Handle: longint; const Buffer; Count: longint): longint;
assembler;
asm
mov eax, 4000h
mov ebx, Handle
mov ecx, Count
mov edx, Buffer
call syscall
jnc @FWriteEnd
mov eax, -1
@FWriteEnd:
end;
function FileSeek (Handle, FOffset, Origin: longint): longint; assembler;
asm
mov eax, Origin
mov ah, 42h
mov ebx, Handle
mov edx, FOffset
call syscall
jnc @FSeekEnd
mov eax, -1
@FSeekEnd:
end;
Function FileSeek (Handle : Longint; FOffset,Origin : Int64) : Int64;
begin
{$warning need to add 64bit call }
Result:=FileSeek(Handle,Longint(Foffset),Longint(Origin));
end;
procedure FileClose (Handle: longint);
begin
if (Handle <= 4) or (os_mode = osOS2) and (Handle <= 2) then
asm
mov eax, 3E00h
mov ebx, Handle
call syscall
end;
end;
function FileTruncate (Handle, Size: longint): boolean; assembler;
asm
mov eax, 7F25h
mov ebx, Handle
mov edx, Size
call syscall
jc @FTruncEnd
mov eax, 4202h
mov ebx, Handle
mov edx, 0
call syscall
mov eax, 0
jnc @FTruncEnd
dec eax
@FTruncEnd:
end;
function FileAge (const FileName: string): longint;
var Handle: longint;
begin
Handle := FileOpen (FileName, 0);
if Handle <> -1 then
begin
Result := FileGetDate (Handle);
FileClose (Handle);
end
else
Result := -1;
end;
function FileExists (const FileName: string): boolean;
{$IFOPT H+}
assembler;
{$ELSE}
var FN: string;
begin
FN := FileName + #0;
{$ENDIF}
asm
mov ax, 4300h
{$IFOPT H+}
mov edx, FileName
{$ELSE}
lea edx, FN
inc edx
{$ENDIF}
call syscall
mov eax, 0
jc @FExistsEnd
test cx, 18h
jnz @FExistsEnd
inc eax
@FExistsEnd:
{$IFOPT H-}
end;
{$ENDIF}
end;
type TRec = record
T, D: word;
end;
PSearchRec = ^SearchRec;
function FindFirst (const Path: string; Attr: longint; var Rslt: TSearchRec): longint;
var SR: PSearchRec;
FStat: PFileFindBuf3;
Count: longint;
Err: longint;
begin
if os_mode = osOS2 then
begin
New (FStat);
Rslt.FindHandle := $FFFFFFFF;
Count := 1;
Err := DosFindFirst (Path, Rslt.FindHandle, Attr, FStat,
SizeOf (FStat^), Count, ilStandard);
if (Err = 0) and (Count = 0) then Err := 18;
FindFirst := -Err;
if Err = 0 then
begin
Rslt.Name := FStat^.Name;
Rslt.Size := FStat^.FileSize;
Rslt.Attr := FStat^.AttrFile;
Rslt.ExcludeAttr := 0;
TRec (Rslt.Time).T := FStat^.TimeLastWrite;
TRec (Rslt.Time).D := FStat^.DateLastWrite;
end;
Dispose (FStat);
end
else
begin
GetMem (SR, SizeOf (SearchRec));
Rslt.FindHandle := longint(SR);
DOS.FindFirst (Path, Attr, SR^);
FindFirst := -DosError;
if DosError = 0 then
begin
Rslt.Time := SR^.Time;
Rslt.Size := SR^.Size;
Rslt.Attr := SR^.Attr;
Rslt.ExcludeAttr := 0;
Rslt.Name := SR^.Name;
end;
end;
end;
function FindNext (var Rslt: TSearchRec): longint;
var SR: PSearchRec;
FStat: PFileFindBuf3;
Count: longint;
Err: longint;
begin
if os_mode = osOS2 then
begin
New (FStat);
Count := 1;
Err := DosFindNext (Rslt.FindHandle, FStat, SizeOf (FStat), Count);
if (Err = 0) and (Count = 0) then Err := 18;
FindNext := -Err;
if Err = 0 then
begin
Rslt.Name := FStat^.Name;
Rslt.Size := FStat^.FileSize;
Rslt.Attr := FStat^.AttrFile;
Rslt.ExcludeAttr := 0;
TRec (Rslt.Time).T := FStat^.TimeLastWrite;
TRec (Rslt.Time).D := FStat^.DateLastWrite;
end;
Dispose (FStat);
end
else
begin
SR := PSearchRec (Rslt.FindHandle);
if SR <> nil then
begin
DOS.FindNext (SR^);
FindNext := -DosError;
if DosError = 0 then
begin
Rslt.Time := SR^.Time;
Rslt.Size := SR^.Size;
Rslt.Attr := SR^.Attr;
Rslt.ExcludeAttr := 0;
Rslt.Name := SR^.Name;
end;
end;
end;
end;
procedure FindClose (var F: TSearchrec);
var SR: PSearchRec;
begin
if os_mode = osOS2 then
begin
DosFindClose (F.FindHandle);
end
else
begin
SR := PSearchRec (F.FindHandle);
DOS.FindClose (SR^);
FreeMem (SR, SizeOf (SearchRec));
end;
F.FindHandle := 0;
end;
function FileGetDate (Handle: longint): longint; assembler;
asm
mov ax, 5700h
mov ebx, Handle
call syscall
mov eax, -1
jc @FGetDateEnd
mov ax, dx
shld eax, ecx, 16
@FGetDateEnd:
end;
function FileSetDate (Handle, Age: longint): longint;
var FStat: PFileStatus0;
RC: longint;
begin
if os_mode = osOS2 then
begin
New (FStat);
RC := DosQueryFileInfo (Handle, ilStandard, FStat,
SizeOf (FStat^));
if RC <> 0 then
FileSetDate := -1
else
begin
FStat^.DateLastAccess := Hi (Age);
FStat^.DateLastWrite := Hi (Age);
FStat^.TimeLastAccess := Lo (Age);
FStat^.TimeLastWrite := Lo (Age);
RC := DosSetFileInfo (Handle, ilStandard, FStat,
SizeOf (FStat^));
if RC <> 0 then
FileSetDate := -1
else
FileSetDate := 0;
end;
Dispose (FStat);
end
else
asm
mov ax, 5701h
mov ebx, Handle
mov cx, word ptr [Age]
mov dx, word ptr [Age + 2]
call syscall
jnc @FSetDateEnd
mov eax, -1
@FSetDateEnd:
mov [ebp - 4], eax
end;
end;
function FileGetAttr (const FileName: string): longint;
{$IFOPT H+}
assembler;
{$ELSE}
var FN: string;
begin
FN := FileName + #0;
{$ENDIF}
asm
mov ax, 4300h
{$IFOPT H+}
mov edx, FileName
{$ELSE}
lea edx, FN
inc edx
{$ENDIF}
call syscall
jnc @FGetAttrEnd
mov eax, -1
@FGetAttrEnd:
{$IFOPT H-}
mov [ebp - 4], eax
end;
{$ENDIF}
end;
function FileSetAttr (const Filename: string; Attr: longint): longint;
{$IFOPT H+}
assembler;
{$ELSE}
var FN: string;
begin
FN := FileName + #0;
{$ENDIF}
asm
mov ax, 4301h
mov ecx, Attr
{$IFOPT H+}
mov edx, FileName
{$ELSE}
lea edx, FN
inc edx
{$ENDIF}
call syscall
mov eax, 0
jnc @FSetAttrEnd
mov eax, -1
@FSetAttrEnd:
{$IFOPT H-}
mov [ebp - 4], eax
end;
{$ENDIF}
end;
function DeleteFile (const FileName: string): boolean;
{$IFOPT H+}
assembler;
{$ELSE}
var FN: string;
begin
FN := FileName + #0;
{$ENDIF}
asm
mov ax, 4100h
{$IFOPT H+}
mov edx, FileName
{$ELSE}
lea edx, FN
inc edx
{$ENDIF}
call syscall
mov eax, 0
jc @FDeleteEnd
inc eax
@FDeleteEnd:
{$IFOPT H-}
mov [ebp - 4], eax
end;
{$ENDIF}
end;
function RenameFile (const OldName, NewName: string): boolean;
{$IFOPT H+}
assembler;
{$ELSE}
var FN1, FN2: string;
begin
FN1 := OldName + #0;
FN2 := NewName + #0;
{$ENDIF}
asm
mov ax, 5600h
{$IFOPT H+}
mov edx, OldName
mov edi, NewName
{$ELSE}
lea edx, FN1
inc edx
lea edi, FN2
inc edi
{$ENDIF}
call syscall
mov eax, 0
jc @FRenameEnd
inc eax
@FRenameEnd:
{$IFOPT H-}
mov [ebp - 4], eax
end;
{$ENDIF}
end;
function FileSearch (const Name, DirList: string): string;
begin
Result := Dos.FSearch (Name, DirList);
end;
{****************************************************************************
Disk Functions
****************************************************************************}
{$ASMMODE ATT}
function DiskFree (Drive: byte): int64;
var FI: TFSinfo;
RC: longint;
begin
if (os_mode = osDOS) or (os_mode = osDPMI) then
{Function 36 is not supported in OS/2.}
asm
movb Drive,%dl
movb $0x36,%ah
call syscall
cmpw $-1,%ax
je .LDISKFREE1
mulw %cx
mulw %bx
shll $16,%edx
movw %ax,%dx
movl $0,%eax
xchgl %edx,%eax
leave
ret
.LDISKFREE1:
cltd
leave
ret
end
else
{In OS/2, we use the filesystem information.}
begin
RC := DosQueryFSInfo (Drive, 1, FI, SizeOf (FI));
if RC = 0 then
DiskFree := int64 (FI.Free_Clusters) *
int64 (FI.Sectors_Per_Cluster) * int64 (FI.Bytes_Per_Sector)
else
DiskFree := -1;
end;
end;
function DiskSize (Drive: byte): int64;
var FI: TFSinfo;
RC: longint;
begin
if (os_mode = osDOS) or (os_mode = osDPMI) then
{Function 36 is not supported in OS/2.}
asm
movb Drive,%dl
movb $0x36,%ah
call syscall
movw %dx,%bx
cmpw $-1,%ax
je .LDISKSIZE1
mulw %cx
mulw %bx
shll $16,%edx
movw %ax,%dx
movl $0,%eax
xchgl %edx,%eax
leave
ret
.LDISKSIZE1:
cltd
leave
ret
end
else
{In OS/2, we use the filesystem information.}
begin
RC := DosQueryFSinfo (Drive, 1, FI, SizeOf (FI));
if RC = 0 then
DiskSize := int64 (FI.Total_Clusters) *
int64 (FI.Sectors_Per_Cluster) * int64 (FI.Bytes_Per_Sector)
else
DiskSize := -1;
end;
end;
function GetCurrentDir: string;
begin
GetDir (0, Result);
end;
function SetCurrentDir (const NewDir: string): boolean;
begin
{$I-}
ChDir (NewDir);
Result := (IOResult = 0);
{$I+}
end;
function CreateDir (const NewDir: string): boolean;
begin
{$I-}
MkDir (NewDir);
Result := (IOResult = 0);
{$I+}
end;
function RemoveDir (const Dir: string): boolean;
begin
{$I-}
RmDir (Dir);
Result := (IOResult = 0);
{$I+}
end;
{****************************************************************************
Time Functions
****************************************************************************}
{$asmmode intel}
procedure GetLocalTime (var SystemTime: TSystemTime); assembler;
asm
(* Expects the default record alignment (word)!!! *)
mov ah, 2Ah
call syscall
mov edi, SystemTime
mov ax, cx
stosw
xor eax, eax
mov al, dl
shl eax, 16
mov al, dh
stosd
push edi
mov ah, 2Ch
call syscall
pop edi
xor eax, eax
mov al, cl
shl eax, 16
mov al, ch
stosd
mov al, dl
shl eax, 16
mov al, dh
stosd
end;
{$asmmode default}
{****************************************************************************
Misc Functions
****************************************************************************}
procedure Beep;
begin
end;
{****************************************************************************
Locale Functions
****************************************************************************}
procedure InitAnsi;
var I: byte;
Country: TCountryCode;
begin
for I := 0 to 255 do
UpperCaseTable [I] := Chr (I);
Move (UpperCaseTable, LowerCaseTable, SizeOf (UpperCaseTable));
if os_mode = osOS2 then
begin
FillChar (Country, SizeOf (Country), 0);
DosMapCase (SizeOf (UpperCaseTable), Country, @UpperCaseTable);
end
else
begin
(* !!! TODO: DOS/DPMI mode support!!! *)
end;
for I := 0 to 255 do
if UpperCaseTable [I] <> Chr (I) then
LowerCaseTable [Ord (UpperCaseTable [I])] := Chr (I);
end;
procedure InitInternational;
var Country: TCountryCode;
CtryInfo: TCountryInfo;
Size: longint;
RC: longint;
begin
Size := 0;
FillChar (Country, SizeOf (Country), 0);
FillChar (CtryInfo, SizeOf (CtryInfo), 0);
RC := DosQueryCtryInfo (SizeOf (CtryInfo), Country, CtryInfo, Size);
if RC = 0 then
begin
DateSeparator := CtryInfo.DateSeparator;
case CtryInfo.DateFormat of
1: begin
ShortDateFormat := 'd/m/y';
LongDateFormat := 'dd" "mmmm" "yyyy';
end;
2: begin
ShortDateFormat := 'y/m/d';
LongDateFormat := 'yyyy" "mmmm" "dd';
end;
3: begin
ShortDateFormat := 'm/d/y';
LongDateFormat := 'mmmm" "dd" "yyyy';
end;
end;
TimeSeparator := CtryInfo.TimeSeparator;
DecimalSeparator := CtryInfo.DecimalSeparator;
ThousandSeparator := CtryInfo.ThousandSeparator;
CurrencyFormat := CtryInfo.CurrencyFormat;
CurrencyString := PChar (CtryInfo.CurrencyUnit);
end;
InitAnsi;
end;
function SysErrorMessage(ErrorCode: Integer): String;
begin
Result:=Format(SUnknownErrorCode,[ErrorCode]);
end;
{****************************************************************************
OS Utils
****************************************************************************}
Function GetEnvironmentVariable(Const EnvVar : String) : String;
var P: PChar;
begin
if DosScanEnv (PChar (EnvVar), P) = 0
then GetEnvironmentVariable := StrPas (P)
else GetEnvironmentVariable := '';
end;
{****************************************************************************
Initialization code
****************************************************************************}
Initialization
InitExceptions; { Initialize exceptions. OS independent }
InitInternational; { Initialize internationalization settings }
Finalization
DoneExceptions;
end.
{
$Log$
Revision 1.13 2001-10-25 21:23:49 peter
* added 64bit fileseek
Revision 1.12 2001/06/03 15:18:01 peter
* eoutofmemory and einvalidpointer fix
Revision 1.11 2001/05/21 20:50:19 hajny
* silly mistyping corrected
Revision 1.10 2001/05/20 18:40:33 hajny
* merging Carl's fixes from the fixes branch
Revision 1.9 2001/02/21 21:23:38 hajny
* GetEnvironmentVariable now really merged
Revision 1.8 2001/02/20 22:14:19 peter
* merged getenvironmentvariable
Revision 1.7 2001/01/13 11:10:59 hajny
* FileCreate and GetLocalTime fixed
Revision 1.6 2000/10/15 20:44:18 hajny
* FindClose correction
Revision 1.5 2000/09/29 21:49:41 jonas
* removed warnings
Revision 1.4 2000/08/30 06:30:55 michael
+ Merged syserrormsg fix
Revision 1.3 2000/08/25 17:23:56 hajny
* Sharing mode error fixed
Revision 1.2 2000/08/20 15:46:46 peter
* sysutils.pp moved to target and merged with disk.inc, filutil.inc
Revision 1.1.2.3 2000/08/25 17:20:57 hajny
* Sharing mode error fixed
Revision 1.1.2.2 2000/08/22 19:21:48 michael
+ Implemented syserrormessage. Made dummies for go32v2 and OS/2
* Changed linux/errors.pp so it uses pchars for storage.
Revision 1.1.2.1 2000/08/20 15:08:32 peter
* forgot the add command :(
}