mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-08-18 16:09:23 +02:00
* sysutils.pp moved to target and merged with disk.inc, filutil.inc
This commit is contained in:
peter
parent
90fc8a53aa
commit
d24c580d24
@ -1,5 +1,5 @@
|
||||
#
|
||||
# Makefile generated by fpcmake v0.99.15 [2000/07/02]
|
||||
# Makefile generated by fpcmake v1.00 [2000/08/14]
|
||||
#
|
||||
|
||||
defaultrule: all
|
||||
@ -926,7 +926,7 @@ ifdef INSTALLPPUFILES
|
||||
ifdef PPUFILES
|
||||
INSTALLPPULINKFILES:=$(shell $(PPUFILES) -S -O $(INSTALLPPUFILES))
|
||||
else
|
||||
INSTALLPPULINKFILES:=$(wildcard $(subst $(PPUEXT),$(OEXT),$(INSTALLPPUFILES)))
|
||||
INSTALLPPULINKFILES:=$(wildcard $(subst $(PPUEXT),$(OEXT),$(INSTALLPPUFILES)) $(addprefix $(LIBPREFIX),$(subst $(PPUEXT),$(STATICLIBEXT),$(INSTALLPPUFILES))))
|
||||
endif
|
||||
endif
|
||||
|
||||
@ -1091,7 +1091,7 @@ ifdef CLEANPPUFILES
|
||||
ifdef PPUFILES
|
||||
CLEANPPULINKFILES:=$(shell $(PPUFILES) $(CLEANPPUFILES))
|
||||
else
|
||||
CLEANPPULINKFILES:=$(wildcard $(subst $(PPUEXT),$(OEXT),$(CLEANPPUFILES)))
|
||||
CLEANPPULINKFILES:=$(wildcard $(subst $(PPUEXT),$(OEXT),$(CLEANPPUFILES)) $(addprefix $(LIBPREFIX),$(subst $(PPUEXT),$(STATICLIBEXT),$(CLEANPPUFILES))))
|
||||
endif
|
||||
endif
|
||||
|
||||
@ -1271,9 +1271,9 @@ graph$(PPUEXT) : graph.pp go32$(PPUEXT) ports$(PPUEXT) $(SYSTEMPPU) \
|
||||
# Delphi Compatible Units
|
||||
#
|
||||
|
||||
sysutils$(PPUEXT) : $(OBJPASDIR)/sysutils.pp $(wildcard $(OBJPASDIR)/*.inc) \
|
||||
filutil.inc disk.inc objpas$(PPUEXT) dos$(PPUEXT) go32$(PPUEXT)
|
||||
$(COMPILER) -I$(OBJPASDIR) $(OBJPASDIR)/sysutils.pp $(REDIR)
|
||||
sysutils$(PPUEXT) : sysutils.pp $(wildcard $(OBJPASDIR)/*.inc) \
|
||||
objpas$(PPUEXT) dos$(PPUEXT) go32$(PPUEXT)
|
||||
$(COMPILER) -I$(OBJPASDIR) sysutils.pp $(REDIR)
|
||||
|
||||
typinfo$(PPUEXT): $(OBJPASDIR)/typinfo.pp objpas$(PPUEXT)
|
||||
$(COMPILER) -Sg $(OBJPASDIR)/typinfo.pp $(REDIR)
|
||||
|
||||
@ -143,9 +143,9 @@ graph$(PPUEXT) : graph.pp go32$(PPUEXT) ports$(PPUEXT) $(SYSTEMPPU) \
|
||||
# Delphi Compatible Units
|
||||
#
|
||||
|
||||
sysutils$(PPUEXT) : $(OBJPASDIR)/sysutils.pp $(wildcard $(OBJPASDIR)/*.inc) \
|
||||
filutil.inc disk.inc objpas$(PPUEXT) dos$(PPUEXT) go32$(PPUEXT)
|
||||
$(COMPILER) -I$(OBJPASDIR) $(OBJPASDIR)/sysutils.pp $(REDIR)
|
||||
sysutils$(PPUEXT) : sysutils.pp $(wildcard $(OBJPASDIR)/*.inc) \
|
||||
objpas$(PPUEXT) dos$(PPUEXT) go32$(PPUEXT)
|
||||
$(COMPILER) -I$(OBJPASDIR) sysutils.pp $(REDIR)
|
||||
|
||||
typinfo$(PPUEXT): $(OBJPASDIR)/typinfo.pp objpas$(PPUEXT)
|
||||
$(COMPILER) -Sg $(OBJPASDIR)/typinfo.pp $(REDIR)
|
||||
|
||||
@ -1,143 +0,0 @@
|
||||
{
|
||||
$Id$
|
||||
This file is part of the Free Pascal run time library.
|
||||
Copyright (c) 1999-2000 by the Free Pascal development team
|
||||
|
||||
Disk functions from Delphi's sysutils.pas
|
||||
|
||||
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.
|
||||
|
||||
**********************************************************************}
|
||||
|
||||
TYPE ExtendedFat32FreeSpaceRec=packed Record
|
||||
RetSize : WORD; { (ret) size of returned structure}
|
||||
Strucversion : WORD; {(call) structure version (0000h)
|
||||
(ret) actual structure version (0000h)}
|
||||
SecPerClus, {number of sectors per cluster}
|
||||
BytePerSec, {number of bytes per sector}
|
||||
AvailClusters, {number of available clusters}
|
||||
TotalClusters, {total number of clusters on the drive}
|
||||
AvailPhysSect, {physical sectors available on the drive}
|
||||
TotalPhysSect, {total physical sectors on the drive}
|
||||
AvailAllocUnits, {Available allocation units}
|
||||
TotalAllocUnits : DWORD; {Total allocation units}
|
||||
Dummy,Dummy2 : DWORD; {8 bytes reserved}
|
||||
END;
|
||||
|
||||
function do_diskdata(drive : byte; Free : BOOLEAN) : Int64;
|
||||
|
||||
VAR S : String;
|
||||
Rec : ExtendedFat32FreeSpaceRec;
|
||||
regs : registers;
|
||||
BEGIN
|
||||
if (swap(dosversion)>=$070A) AND LFNSupport then
|
||||
begin
|
||||
DosError:=0;
|
||||
S:='C:\'#0;
|
||||
if Drive=0 then
|
||||
begin
|
||||
GetDir(Drive,S);
|
||||
Setlength(S,4);
|
||||
S[4]:=#0;
|
||||
end
|
||||
else
|
||||
S[1]:=chr(Drive+64);
|
||||
Rec.Strucversion:=0;
|
||||
dosmemput(tb_segment,tb_offset,Rec,SIZEOF(ExtendedFat32FreeSpaceRec));
|
||||
dosmemput(tb_segment,tb_offset+Sizeof(ExtendedFat32FreeSpaceRec)+1,S[1],4);
|
||||
regs.dx:=tb_offset+Sizeof(ExtendedFat32FreeSpaceRec)+1;
|
||||
regs.ds:=tb_segment;
|
||||
regs.di:=tb_offset;
|
||||
regs.es:=tb_segment;
|
||||
regs.cx:=Sizeof(ExtendedFat32FreeSpaceRec);
|
||||
regs.ax:=$7303;
|
||||
msdos(regs);
|
||||
if regs.ax<>$ffff then
|
||||
begin
|
||||
copyfromdos(rec,Sizeof(ExtendedFat32FreeSpaceRec));
|
||||
if Free then
|
||||
Do_DiskData:=int64(rec.AvailAllocUnits)*rec.SecPerClus*rec.BytePerSec
|
||||
else
|
||||
Do_DiskData:=int64(rec.TotalAllocUnits)*rec.SecPerClus*rec.BytePerSec;
|
||||
end
|
||||
else
|
||||
Do_DiskData:=-1;
|
||||
end
|
||||
else
|
||||
begin
|
||||
DosError:=0;
|
||||
regs.dl:=drive;
|
||||
regs.ah:=$36;
|
||||
msdos(regs);
|
||||
if regs.ax<>$FFFF then
|
||||
begin
|
||||
if Free then
|
||||
Do_DiskData:=int64(regs.ax)*regs.bx*regs.cx
|
||||
else
|
||||
Do_DiskData:=int64(regs.ax)*regs.cx*regs.dx;
|
||||
end
|
||||
else
|
||||
do_diskdata:=-1;
|
||||
end;
|
||||
end;
|
||||
|
||||
function diskfree(drive : byte) : int64;
|
||||
|
||||
begin
|
||||
diskfree:=Do_DiskData(drive,TRUE);
|
||||
end;
|
||||
|
||||
|
||||
function disksize(drive : byte) : int64;
|
||||
begin
|
||||
disksize:=Do_DiskData(drive,false);
|
||||
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;
|
||||
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.3 2000-07-14 10:33:09 michael
|
||||
+ Conditionals fixed
|
||||
|
||||
Revision 1.2 2000/07/13 11:33:39 michael
|
||||
+ removed logs
|
||||
|
||||
}
|
||||
@ -1,466 +0,0 @@
|
||||
{
|
||||
$Id$
|
||||
This file is part of the Free Pascal run time library.
|
||||
Copyright (c) 1999-2000 by the Free Pascal development team
|
||||
|
||||
File utility calls
|
||||
|
||||
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.
|
||||
|
||||
**********************************************************************}
|
||||
|
||||
{******************************************************************************}
|
||||
{ private functions }
|
||||
{******************************************************************************}
|
||||
|
||||
{ some internal constants }
|
||||
|
||||
const
|
||||
ofRead = $0000; { Open for reading }
|
||||
ofWrite = $0001; { Open for writing }
|
||||
ofReadWrite = $0002; { Open for reading/writing }
|
||||
faFail = $0000; { Fail if file does not exist }
|
||||
faCreate = $0010; { Create if file does not exist }
|
||||
faOpen = $0001; { Open if file exists }
|
||||
faOpenReplace = $0002; { Clear if file exists }
|
||||
|
||||
|
||||
{ converts S to a pchar and copies it to the transfer-buffer. }
|
||||
|
||||
procedure StringToTB(const S: string);
|
||||
var P: pchar; Len: integer;
|
||||
begin
|
||||
Len := Length(S) + 1;
|
||||
P := StrPCopy(StrAlloc(Len), S);
|
||||
SysCopyToDos(longint(P), Len);
|
||||
StrDispose(P);
|
||||
end ;
|
||||
|
||||
{ Native OpenFile function.
|
||||
if return value <> 0 call failed. }
|
||||
|
||||
function OpenFile(const FileName: string; var Handle: longint; Mode, Action: word): longint;
|
||||
var
|
||||
Regs: registers;
|
||||
begin
|
||||
result := 0;
|
||||
Handle := 0;
|
||||
StringToTB(FileName);
|
||||
if LFNSupport then Regs.Eax:=$716c
|
||||
else Regs.Eax:=$6c00;
|
||||
Regs.Edx := Action; { Action if file exists/not exists }
|
||||
Regs.Ds := tb_segment;
|
||||
Regs.Esi := tb_offset;
|
||||
Regs.Ebx := $2000 + (Mode and $ff); { file open mode }
|
||||
Regs.Ecx := $20; { Attributes }
|
||||
RealIntr($21, Regs);
|
||||
if Regs.Flags and CarryFlag <> 0 then result := Regs.Ax
|
||||
else Handle := Regs.Ax;
|
||||
end ;
|
||||
|
||||
{******************************************************************************}
|
||||
{ Public functions }
|
||||
{******************************************************************************}
|
||||
|
||||
|
||||
Function FileOpen (Const FileName : string; Mode : Integer) : Longint;
|
||||
var e: integer;
|
||||
Begin
|
||||
e := OpenFile(FileName, result, Mode, faOpen);
|
||||
if e <> 0 then result := -1;
|
||||
end ;
|
||||
|
||||
|
||||
Function FileCreate (Const FileName : String) : Longint;
|
||||
var e: integer;
|
||||
begin
|
||||
e := OpenFile(FileName, result, ofReadWrite, faCreate or faOpenReplace);
|
||||
if e <> 0 then result := -1;
|
||||
end;
|
||||
|
||||
|
||||
Function FileRead (Handle : Longint; Var Buffer; Count : longint) : Longint;
|
||||
begin
|
||||
result := Do_Read(Handle, longint(@Buffer), Count);
|
||||
end;
|
||||
|
||||
|
||||
Function FileWrite (Handle : Longint; const Buffer; Count : Longint) : Longint;
|
||||
begin
|
||||
result := Do_Write(Handle, longint(@Buffer), Count);
|
||||
end;
|
||||
|
||||
|
||||
Function FileSeek (Handle, FOffset, Origin : Longint) : Longint;
|
||||
var Regs: registers;
|
||||
begin
|
||||
Regs.Eax := $4200;
|
||||
Regs.Al := Origin;
|
||||
Regs.Edx := Lo(FOffset);
|
||||
Regs.Ecx := Hi(FOffset);
|
||||
Regs.Ebx := Handle;
|
||||
RealIntr($21, Regs);
|
||||
if Regs.Flags and CarryFlag <> 0 then
|
||||
result := -1
|
||||
else begin
|
||||
LongRec(result).Lo := Regs.Ax;
|
||||
LongRec(result).Hi := Regs.Dx;
|
||||
end ;
|
||||
end;
|
||||
|
||||
|
||||
Procedure FileClose (Handle : Longint);
|
||||
var Regs: registers;
|
||||
begin
|
||||
if Handle<=4 then
|
||||
exit;
|
||||
Regs.Eax := $3e00;
|
||||
Regs.Ebx := Handle;
|
||||
RealIntr($21, Regs);
|
||||
end;
|
||||
|
||||
Function FileTruncate (Handle,Size: Longint) : boolean;
|
||||
var
|
||||
regs : trealregs;
|
||||
begin
|
||||
FileSeek(Handle,Size,0);
|
||||
Regs.realecx := 0;
|
||||
Regs.realedx := tb_offset;
|
||||
Regs.ds := tb_segment;
|
||||
Regs.ebx := Handle;
|
||||
Regs.eax:=$4000;
|
||||
RealIntr($21, Regs);
|
||||
FileTruncate:=(regs.realflags and carryflag)=0;
|
||||
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;
|
||||
var Handle: longint;
|
||||
begin
|
||||
//!! This can be done quicker, need to find out how
|
||||
Result := (OpenFile(FileName, Handle, ofRead, faOpen) = 0);
|
||||
if Handle <> 0 then
|
||||
FileClose(Handle);
|
||||
end;
|
||||
|
||||
Type PSearchrec = ^Searchrec;
|
||||
|
||||
|
||||
Function FindFirst (Const Path : String; Attr : Longint; Var Rslt : TSearchRec) : Longint;
|
||||
|
||||
Var Sr : PSearchrec;
|
||||
|
||||
begin
|
||||
//!! Sr := New(PSearchRec);
|
||||
getmem(sr,sizeof(searchrec));
|
||||
Rslt.FindHandle := longint(Sr);
|
||||
DOS.FindFirst(Path, Attr, Sr^);
|
||||
result := -DosError;
|
||||
if result = 0 then begin
|
||||
Rslt.Time := Sr^.Time;
|
||||
Rslt.Size := Sr^.Size;
|
||||
Rslt.Attr := Sr^.Attr;
|
||||
Rslt.ExcludeAttr := 0;
|
||||
Rslt.Name := Sr^.Name;
|
||||
end ;
|
||||
end;
|
||||
|
||||
|
||||
Function FindNext (Var Rslt : TSearchRec) : Longint;
|
||||
|
||||
var Sr: PSearchRec;
|
||||
|
||||
begin
|
||||
Sr := PSearchRec(Rslt.FindHandle);
|
||||
if Sr <> nil then begin
|
||||
DOS.FindNext(Sr^);
|
||||
result := -DosError;
|
||||
if result = 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;
|
||||
|
||||
|
||||
Procedure FindClose (Var F : TSearchrec);
|
||||
|
||||
var Sr: PSearchRec;
|
||||
|
||||
begin
|
||||
Sr := PSearchRec(F.FindHandle);
|
||||
if Sr <> nil then
|
||||
begin
|
||||
//!! Dispose(Sr);
|
||||
// This call is non dummy if LFNSupport is true PM
|
||||
DOS.FindClose(SR^);
|
||||
freemem(sr,sizeof(searchrec));
|
||||
end;
|
||||
F.FindHandle := 0;
|
||||
end;
|
||||
|
||||
|
||||
Function FileGetDate (Handle : Longint) : Longint;
|
||||
var Regs: registers;
|
||||
begin
|
||||
//!! for win95 an alternative function is available.
|
||||
Regs.Ebx := Handle;
|
||||
Regs.Eax := $5700;
|
||||
RealIntr($21, Regs);
|
||||
if Regs.Flags and CarryFlag <> 0 then result := -1
|
||||
else begin
|
||||
LongRec(result).Lo := Regs.cx;
|
||||
LongRec(result).Hi := Regs.dx;
|
||||
end ;
|
||||
end;
|
||||
|
||||
|
||||
Function FileSetDate (Handle, Age : Longint) : Longint;
|
||||
var Regs: registers;
|
||||
begin
|
||||
Regs.Ebx := Handle;
|
||||
Regs.Eax := $5701;
|
||||
Regs.Ecx := Lo(Age);
|
||||
Regs.Edx := Hi(Age);
|
||||
RealIntr($21, Regs);
|
||||
if Regs.Flags and CarryFlag <> 0 then result := -Regs.Ax
|
||||
else result := 0;
|
||||
end;
|
||||
|
||||
|
||||
Function FileGetAttr (Const FileName : String) : Longint;
|
||||
|
||||
var Regs: registers;
|
||||
|
||||
begin
|
||||
StringToTB(FileName);
|
||||
Regs.Edx := tb_offset;
|
||||
Regs.Ds := tb_segment;
|
||||
if LFNSupport then
|
||||
begin
|
||||
Regs.Ax := $7143;
|
||||
Regs.Bx := 0;
|
||||
end
|
||||
else
|
||||
Regs.Ax := $4300;
|
||||
RealIntr($21, Regs);
|
||||
if Regs.Flags and CarryFlag <> 0 then
|
||||
result := -1
|
||||
else
|
||||
result := Regs.Cx;
|
||||
end;
|
||||
|
||||
|
||||
Function FileSetAttr (Const Filename : String; Attr: longint) : Longint;
|
||||
|
||||
var Regs: registers;
|
||||
|
||||
begin
|
||||
StringToTB(FileName);
|
||||
Regs.Edx := tb_offset;
|
||||
Regs.Ds := tb_segment;
|
||||
if LFNSupport then
|
||||
begin
|
||||
Regs.Ax := $7143;
|
||||
Regs.Bx := 1;
|
||||
end
|
||||
else
|
||||
Regs.Ax := $4301;
|
||||
Regs.Cx := Attr;
|
||||
RealIntr($21, Regs);
|
||||
if Regs.Flags and CarryFlag <> 0 then result := -Regs.Ax
|
||||
else result := 0;
|
||||
end;
|
||||
|
||||
|
||||
Function DeleteFile (Const FileName : String) : Boolean;
|
||||
|
||||
var Regs: registers;
|
||||
|
||||
begin
|
||||
StringToTB(FileName);
|
||||
Regs.Edx := tb_offset;
|
||||
Regs.Ds := tb_segment;
|
||||
if LFNSupport then
|
||||
Regs.Eax := $7141
|
||||
else
|
||||
Regs.Eax := $4100;
|
||||
Regs.Esi := 0;
|
||||
Regs.Ecx := 0;
|
||||
RealIntr($21, Regs);
|
||||
result := (Regs.Flags and CarryFlag = 0);
|
||||
end;
|
||||
|
||||
|
||||
Function RenameFile (Const OldName, NewName : String) : Boolean;
|
||||
|
||||
var Regs: registers;
|
||||
|
||||
begin
|
||||
StringToTB(OldName + #0 + NewName);
|
||||
Regs.Edx := tb_offset;
|
||||
Regs.Ds := tb_segment;
|
||||
Regs.Edi := tb_offset + Length(OldName) + 1;
|
||||
Regs.Es := tb_segment;
|
||||
if LFNSupport then
|
||||
Regs.Eax := $7156
|
||||
else
|
||||
Regs.Eax := $5600;
|
||||
Regs.Ecx := $ff;
|
||||
RealIntr($21, Regs);
|
||||
result := (Regs.Flags and CarryFlag = 0);
|
||||
end;
|
||||
|
||||
|
||||
Function FileSearch (Const Name, DirList : String) : String;
|
||||
|
||||
begin
|
||||
result := DOS.FSearch(Name, DirList);
|
||||
end;
|
||||
|
||||
Procedure GetLocalTime(var SystemTime: TSystemTime);
|
||||
|
||||
var Regs: Registers;
|
||||
|
||||
begin
|
||||
Regs.ah := $2C;
|
||||
RealIntr($21, Regs);
|
||||
SystemTime.Hour := Regs.Ch;
|
||||
SystemTime.Minute := Regs.Cl;
|
||||
SystemTime.Second := Regs.Dh;
|
||||
SystemTime.MilliSecond := Regs.Dl;
|
||||
Regs.ah := $2A;
|
||||
RealIntr($21, Regs);
|
||||
SystemTime.Year := Regs.Cx;
|
||||
SystemTime.Month := Regs.Dh;
|
||||
SystemTime.Day := Regs.Dl;
|
||||
end ;
|
||||
|
||||
{ ---------------------------------------------------------------------
|
||||
Internationalization settings
|
||||
---------------------------------------------------------------------}
|
||||
|
||||
|
||||
{ Codepage constants }
|
||||
const
|
||||
CP_US = 437;
|
||||
CP_MultiLingual = 850;
|
||||
CP_SlavicLatin2 = 852;
|
||||
CP_Turkish = 857;
|
||||
CP_Portugal = 860;
|
||||
CP_IceLand = 861;
|
||||
CP_Canada = 863;
|
||||
CP_NorwayDenmark = 865;
|
||||
|
||||
{ CountryInfo }
|
||||
type
|
||||
TCountryInfo = packed record
|
||||
InfoId: byte;
|
||||
case integer of
|
||||
1: ( Size: word;
|
||||
CountryId: word;
|
||||
CodePage: word;
|
||||
CountryInfo: array[0..33] of byte );
|
||||
2: ( UpperCaseTable: longint );
|
||||
4: ( FilenameUpperCaseTable: longint );
|
||||
5: ( FilecharacterTable: longint );
|
||||
6: ( CollatingTable: longint );
|
||||
7: ( DBCSLeadByteTable: longint );
|
||||
end ;
|
||||
|
||||
|
||||
procedure GetExtendedCountryInfo(InfoId: integer; CodePage, CountryId: word; var CountryInfo: TCountryInfo);
|
||||
|
||||
Var Regs: Registers;
|
||||
|
||||
begin
|
||||
Regs.AH := $65;
|
||||
Regs.AL := InfoId;
|
||||
Regs.BX := CodePage;
|
||||
Regs.DX := CountryId;
|
||||
Regs.ES := transfer_buffer div 16;
|
||||
Regs.DI := transfer_buffer and 15;
|
||||
Regs.CX := SizeOf(TCountryInfo);
|
||||
RealIntr($21, Regs);
|
||||
DosMemGet(transfer_buffer div 16,
|
||||
transfer_buffer and 15,
|
||||
CountryInfo, Regs.CX );
|
||||
end;
|
||||
|
||||
procedure InitAnsi;
|
||||
|
||||
var CountryInfo: TCountryInfo; i: integer;
|
||||
|
||||
begin
|
||||
{ Fill table entries 0 to 127 }
|
||||
for i := 0 to 96 do
|
||||
UpperCaseTable[i] := chr(i);
|
||||
for i := 97 to 122 do
|
||||
UpperCaseTable[i] := chr(i - 32);
|
||||
for i := 123 to 127 do
|
||||
UpperCaseTable[i] := chr(i);
|
||||
for i := 0 to 64 do
|
||||
LowerCaseTable[i] := chr(i);
|
||||
for i := 65 to 90 do
|
||||
LowerCaseTable[i] := chr(i + 32);
|
||||
for i := 91 to 255 do
|
||||
LowerCaseTable[i] := chr(i);
|
||||
|
||||
{ Get country and codepage info }
|
||||
GetExtendedCountryInfo(1, $FFFF, $FFFF, CountryInfo);
|
||||
if CountryInfo.CodePage = 850 then
|
||||
begin
|
||||
{ Special, known case }
|
||||
Move(CP850UCT, UpperCaseTable[128], 128);
|
||||
Move(CP850LCT, LowerCaseTable[128], 128);
|
||||
end
|
||||
else
|
||||
begin
|
||||
{ this needs to be checked !!
|
||||
this is correct only if UpperCaseTable is
|
||||
and Offset:Segment word record (PM) }
|
||||
{ get the uppercase table from dosmemory }
|
||||
GetExtendedCountryInfo(2, $FFFF, $FFFF, CountryInfo);
|
||||
DosMemGet(CountryInfo.UpperCaseTable shr 16, 2 + CountryInfo.UpperCaseTable and 65535, UpperCaseTable[128], 128);
|
||||
for i := 128 to 255 do
|
||||
begin
|
||||
if UpperCaseTable[i] <> chr(i) then
|
||||
LowerCaseTable[ord(UpperCaseTable[i])] := chr(i);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
Procedure InitInternational;
|
||||
|
||||
{ This routine is called by the unit startup code. }
|
||||
|
||||
begin
|
||||
{ Init upper/lowercase tables }
|
||||
InitAnsi
|
||||
end;
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.2 2000-07-13 11:33:40 michael
|
||||
+ removed logs
|
||||
|
||||
}
|
||||
641
rtl/go32v2/sysutils.pp
Normal file
641
rtl/go32v2/sysutils.pp
Normal file
@ -0,0 +1,641 @@
|
||||
{
|
||||
$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 Go32v2
|
||||
|
||||
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
|
||||
go32,dos;
|
||||
|
||||
{ Include platform independent interface part }
|
||||
{$i sysutilh.inc}
|
||||
|
||||
|
||||
implementation
|
||||
|
||||
{ Include platform independent implementation part }
|
||||
{$i sysutils.inc}
|
||||
|
||||
|
||||
{****************************************************************************
|
||||
File Functions
|
||||
****************************************************************************}
|
||||
|
||||
{ some internal constants }
|
||||
|
||||
const
|
||||
ofRead = $0000; { Open for reading }
|
||||
ofWrite = $0001; { Open for writing }
|
||||
ofReadWrite = $0002; { Open for reading/writing }
|
||||
faFail = $0000; { Fail if file does not exist }
|
||||
faCreate = $0010; { Create if file does not exist }
|
||||
faOpen = $0001; { Open if file exists }
|
||||
faOpenReplace = $0002; { Clear if file exists }
|
||||
|
||||
Type
|
||||
PSearchrec = ^Searchrec;
|
||||
|
||||
{ converts S to a pchar and copies it to the transfer-buffer. }
|
||||
|
||||
procedure StringToTB(const S: string);
|
||||
var
|
||||
P: pchar;
|
||||
Len: integer;
|
||||
begin
|
||||
Len := Length(S) + 1;
|
||||
P := StrPCopy(StrAlloc(Len), S);
|
||||
SysCopyToDos(longint(P), Len);
|
||||
StrDispose(P);
|
||||
end ;
|
||||
|
||||
{ Native OpenFile function.
|
||||
if return value <> 0 call failed. }
|
||||
|
||||
function OpenFile(const FileName: string; var Handle: longint; Mode, Action: word): longint;
|
||||
var
|
||||
Regs: registers;
|
||||
begin
|
||||
result := 0;
|
||||
Handle := 0;
|
||||
StringToTB(FileName);
|
||||
if LFNSupport then Regs.Eax:=$716c
|
||||
else Regs.Eax:=$6c00;
|
||||
Regs.Edx := Action; { Action if file exists/not exists }
|
||||
Regs.Ds := tb_segment;
|
||||
Regs.Esi := tb_offset;
|
||||
Regs.Ebx := $2000 + (Mode and $ff); { file open mode }
|
||||
Regs.Ecx := $20; { Attributes }
|
||||
RealIntr($21, Regs);
|
||||
if Regs.Flags and CarryFlag <> 0 then result := Regs.Ax
|
||||
else Handle := Regs.Ax;
|
||||
end ;
|
||||
|
||||
|
||||
Function FileOpen (Const FileName : string; Mode : Integer) : Longint;
|
||||
var
|
||||
e: integer;
|
||||
Begin
|
||||
e := OpenFile(FileName, result, Mode, faOpen);
|
||||
if e <> 0 then
|
||||
result := -1;
|
||||
end;
|
||||
|
||||
|
||||
Function FileCreate (Const FileName : String) : Longint;
|
||||
var
|
||||
e: integer;
|
||||
begin
|
||||
e := OpenFile(FileName, result, ofReadWrite, faCreate or faOpenReplace);
|
||||
if e <> 0 then
|
||||
result := -1;
|
||||
end;
|
||||
|
||||
|
||||
Function FileRead (Handle : Longint; Var Buffer; Count : longint) : Longint;
|
||||
begin
|
||||
result := Do_Read(Handle, longint(@Buffer), Count);
|
||||
end;
|
||||
|
||||
|
||||
Function FileWrite (Handle : Longint; const Buffer; Count : Longint) : Longint;
|
||||
begin
|
||||
result := Do_Write(Handle, longint(@Buffer), Count);
|
||||
end;
|
||||
|
||||
|
||||
Function FileSeek (Handle, FOffset, Origin : Longint) : Longint;
|
||||
var
|
||||
Regs: registers;
|
||||
begin
|
||||
Regs.Eax := $4200;
|
||||
Regs.Al := Origin;
|
||||
Regs.Edx := Lo(FOffset);
|
||||
Regs.Ecx := Hi(FOffset);
|
||||
Regs.Ebx := Handle;
|
||||
RealIntr($21, Regs);
|
||||
if Regs.Flags and CarryFlag <> 0 then
|
||||
result := -1
|
||||
else begin
|
||||
LongRec(result).Lo := Regs.Ax;
|
||||
LongRec(result).Hi := Regs.Dx;
|
||||
end ;
|
||||
end;
|
||||
|
||||
|
||||
Procedure FileClose (Handle : Longint);
|
||||
var
|
||||
Regs: registers;
|
||||
begin
|
||||
if Handle<=4 then
|
||||
exit;
|
||||
Regs.Eax := $3e00;
|
||||
Regs.Ebx := Handle;
|
||||
RealIntr($21, Regs);
|
||||
end;
|
||||
|
||||
|
||||
Function FileTruncate (Handle,Size: Longint) : boolean;
|
||||
var
|
||||
regs : trealregs;
|
||||
begin
|
||||
FileSeek(Handle,Size,0);
|
||||
Regs.realecx := 0;
|
||||
Regs.realedx := tb_offset;
|
||||
Regs.ds := tb_segment;
|
||||
Regs.ebx := Handle;
|
||||
Regs.eax:=$4000;
|
||||
RealIntr($21, Regs);
|
||||
FileTruncate:=(regs.realflags and carryflag)=0;
|
||||
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;
|
||||
var Handle: longint;
|
||||
begin
|
||||
//!! This can be done quicker, need to find out how
|
||||
Result := (OpenFile(FileName, Handle, ofRead, faOpen) = 0);
|
||||
if Handle <> 0 then
|
||||
FileClose(Handle);
|
||||
end;
|
||||
|
||||
|
||||
Function FindFirst (Const Path : String; Attr : Longint; Var Rslt : TSearchRec) : Longint;
|
||||
|
||||
Var Sr : PSearchrec;
|
||||
|
||||
begin
|
||||
//!! Sr := New(PSearchRec);
|
||||
getmem(sr,sizeof(searchrec));
|
||||
Rslt.FindHandle := longint(Sr);
|
||||
DOS.FindFirst(Path, Attr, Sr^);
|
||||
result := -DosError;
|
||||
if result = 0 then
|
||||
begin
|
||||
Rslt.Time := Sr^.Time;
|
||||
Rslt.Size := Sr^.Size;
|
||||
Rslt.Attr := Sr^.Attr;
|
||||
Rslt.ExcludeAttr := 0;
|
||||
Rslt.Name := Sr^.Name;
|
||||
end ;
|
||||
end;
|
||||
|
||||
|
||||
Function FindNext (Var Rslt : TSearchRec) : Longint;
|
||||
var
|
||||
Sr: PSearchRec;
|
||||
begin
|
||||
Sr := PSearchRec(Rslt.FindHandle);
|
||||
if Sr <> nil then
|
||||
begin
|
||||
DOS.FindNext(Sr^);
|
||||
result := -DosError;
|
||||
if result = 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;
|
||||
|
||||
|
||||
Procedure FindClose (Var F : TSearchrec);
|
||||
var
|
||||
Sr: PSearchRec;
|
||||
begin
|
||||
Sr := PSearchRec(F.FindHandle);
|
||||
if Sr <> nil then
|
||||
begin
|
||||
//!! Dispose(Sr);
|
||||
// This call is non dummy if LFNSupport is true PM
|
||||
DOS.FindClose(SR^);
|
||||
freemem(sr,sizeof(searchrec));
|
||||
end;
|
||||
F.FindHandle := 0;
|
||||
end;
|
||||
|
||||
|
||||
Function FileGetDate (Handle : Longint) : Longint;
|
||||
var
|
||||
Regs: registers;
|
||||
begin
|
||||
//!! for win95 an alternative function is available.
|
||||
Regs.Ebx := Handle;
|
||||
Regs.Eax := $5700;
|
||||
RealIntr($21, Regs);
|
||||
if Regs.Flags and CarryFlag <> 0 then
|
||||
result := -1
|
||||
else
|
||||
begin
|
||||
LongRec(result).Lo := Regs.cx;
|
||||
LongRec(result).Hi := Regs.dx;
|
||||
end ;
|
||||
end;
|
||||
|
||||
|
||||
Function FileSetDate (Handle, Age : Longint) : Longint;
|
||||
var
|
||||
Regs: registers;
|
||||
begin
|
||||
Regs.Ebx := Handle;
|
||||
Regs.Eax := $5701;
|
||||
Regs.Ecx := Lo(Age);
|
||||
Regs.Edx := Hi(Age);
|
||||
RealIntr($21, Regs);
|
||||
if Regs.Flags and CarryFlag <> 0 then
|
||||
result := -Regs.Ax
|
||||
else
|
||||
result := 0;
|
||||
end;
|
||||
|
||||
|
||||
Function FileGetAttr (Const FileName : String) : Longint;
|
||||
var
|
||||
Regs: registers;
|
||||
begin
|
||||
StringToTB(FileName);
|
||||
Regs.Edx := tb_offset;
|
||||
Regs.Ds := tb_segment;
|
||||
if LFNSupport then
|
||||
begin
|
||||
Regs.Ax := $7143;
|
||||
Regs.Bx := 0;
|
||||
end
|
||||
else
|
||||
Regs.Ax := $4300;
|
||||
RealIntr($21, Regs);
|
||||
if Regs.Flags and CarryFlag <> 0 then
|
||||
result := -1
|
||||
else
|
||||
result := Regs.Cx;
|
||||
end;
|
||||
|
||||
|
||||
Function FileSetAttr (Const Filename : String; Attr: longint) : Longint;
|
||||
var
|
||||
Regs: registers;
|
||||
begin
|
||||
StringToTB(FileName);
|
||||
Regs.Edx := tb_offset;
|
||||
Regs.Ds := tb_segment;
|
||||
if LFNSupport then
|
||||
begin
|
||||
Regs.Ax := $7143;
|
||||
Regs.Bx := 1;
|
||||
end
|
||||
else
|
||||
Regs.Ax := $4301;
|
||||
Regs.Cx := Attr;
|
||||
RealIntr($21, Regs);
|
||||
if Regs.Flags and CarryFlag <> 0 then
|
||||
result := -Regs.Ax
|
||||
else
|
||||
result := 0;
|
||||
end;
|
||||
|
||||
|
||||
Function DeleteFile (Const FileName : String) : Boolean;
|
||||
var
|
||||
Regs: registers;
|
||||
begin
|
||||
StringToTB(FileName);
|
||||
Regs.Edx := tb_offset;
|
||||
Regs.Ds := tb_segment;
|
||||
if LFNSupport then
|
||||
Regs.Eax := $7141
|
||||
else
|
||||
Regs.Eax := $4100;
|
||||
Regs.Esi := 0;
|
||||
Regs.Ecx := 0;
|
||||
RealIntr($21, Regs);
|
||||
result := (Regs.Flags and CarryFlag = 0);
|
||||
end;
|
||||
|
||||
|
||||
Function RenameFile (Const OldName, NewName : String) : Boolean;
|
||||
var
|
||||
Regs: registers;
|
||||
begin
|
||||
StringToTB(OldName + #0 + NewName);
|
||||
Regs.Edx := tb_offset;
|
||||
Regs.Ds := tb_segment;
|
||||
Regs.Edi := tb_offset + Length(OldName) + 1;
|
||||
Regs.Es := tb_segment;
|
||||
if LFNSupport then
|
||||
Regs.Eax := $7156
|
||||
else
|
||||
Regs.Eax := $5600;
|
||||
Regs.Ecx := $ff;
|
||||
RealIntr($21, Regs);
|
||||
result := (Regs.Flags and CarryFlag = 0);
|
||||
end;
|
||||
|
||||
|
||||
Function FileSearch (Const Name, DirList : String) : String;
|
||||
begin
|
||||
result := DOS.FSearch(Name, DirList);
|
||||
end;
|
||||
|
||||
|
||||
{****************************************************************************
|
||||
Disk Functions
|
||||
****************************************************************************}
|
||||
|
||||
TYPE ExtendedFat32FreeSpaceRec=packed Record
|
||||
RetSize : WORD; { (ret) size of returned structure}
|
||||
Strucversion : WORD; {(call) structure version (0000h)
|
||||
(ret) actual structure version (0000h)}
|
||||
SecPerClus, {number of sectors per cluster}
|
||||
BytePerSec, {number of bytes per sector}
|
||||
AvailClusters, {number of available clusters}
|
||||
TotalClusters, {total number of clusters on the drive}
|
||||
AvailPhysSect, {physical sectors available on the drive}
|
||||
TotalPhysSect, {total physical sectors on the drive}
|
||||
AvailAllocUnits, {Available allocation units}
|
||||
TotalAllocUnits : DWORD; {Total allocation units}
|
||||
Dummy,Dummy2 : DWORD; {8 bytes reserved}
|
||||
END;
|
||||
|
||||
function do_diskdata(drive : byte; Free : BOOLEAN) : Int64;
|
||||
VAR S : String;
|
||||
Rec : ExtendedFat32FreeSpaceRec;
|
||||
regs : registers;
|
||||
BEGIN
|
||||
if (swap(dosversion)>=$070A) AND LFNSupport then
|
||||
begin
|
||||
DosError:=0;
|
||||
S:='C:\'#0;
|
||||
if Drive=0 then
|
||||
begin
|
||||
GetDir(Drive,S);
|
||||
Setlength(S,4);
|
||||
S[4]:=#0;
|
||||
end
|
||||
else
|
||||
S[1]:=chr(Drive+64);
|
||||
Rec.Strucversion:=0;
|
||||
dosmemput(tb_segment,tb_offset,Rec,SIZEOF(ExtendedFat32FreeSpaceRec));
|
||||
dosmemput(tb_segment,tb_offset+Sizeof(ExtendedFat32FreeSpaceRec)+1,S[1],4);
|
||||
regs.dx:=tb_offset+Sizeof(ExtendedFat32FreeSpaceRec)+1;
|
||||
regs.ds:=tb_segment;
|
||||
regs.di:=tb_offset;
|
||||
regs.es:=tb_segment;
|
||||
regs.cx:=Sizeof(ExtendedFat32FreeSpaceRec);
|
||||
regs.ax:=$7303;
|
||||
msdos(regs);
|
||||
if regs.ax<>$ffff then
|
||||
begin
|
||||
copyfromdos(rec,Sizeof(ExtendedFat32FreeSpaceRec));
|
||||
if Free then
|
||||
Do_DiskData:=int64(rec.AvailAllocUnits)*rec.SecPerClus*rec.BytePerSec
|
||||
else
|
||||
Do_DiskData:=int64(rec.TotalAllocUnits)*rec.SecPerClus*rec.BytePerSec;
|
||||
end
|
||||
else
|
||||
Do_DiskData:=-1;
|
||||
end
|
||||
else
|
||||
begin
|
||||
DosError:=0;
|
||||
regs.dl:=drive;
|
||||
regs.ah:=$36;
|
||||
msdos(regs);
|
||||
if regs.ax<>$FFFF then
|
||||
begin
|
||||
if Free then
|
||||
Do_DiskData:=int64(regs.ax)*regs.bx*regs.cx
|
||||
else
|
||||
Do_DiskData:=int64(regs.ax)*regs.cx*regs.dx;
|
||||
end
|
||||
else
|
||||
do_diskdata:=-1;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
function diskfree(drive : byte) : int64;
|
||||
begin
|
||||
diskfree:=Do_DiskData(drive,TRUE);
|
||||
end;
|
||||
|
||||
|
||||
function disksize(drive : byte) : int64;
|
||||
begin
|
||||
disksize:=Do_DiskData(drive,false);
|
||||
end;
|
||||
|
||||
|
||||
Function GetCurrentDir : String;
|
||||
begin
|
||||
GetDir(0, result);
|
||||
end;
|
||||
|
||||
|
||||
Function SetCurrentDir (Const NewDir : String) : Boolean;
|
||||
begin
|
||||
{$I-}
|
||||
ChDir(NewDir);
|
||||
{$I+}
|
||||
result := (IOResult = 0);
|
||||
end;
|
||||
|
||||
|
||||
Function CreateDir (Const NewDir : String) : Boolean;
|
||||
begin
|
||||
{$I-}
|
||||
MkDir(NewDir);
|
||||
{$I+}
|
||||
result := (IOResult = 0);
|
||||
end;
|
||||
|
||||
|
||||
Function RemoveDir (Const Dir : String) : Boolean;
|
||||
begin
|
||||
{$I-}
|
||||
RmDir(Dir);
|
||||
{$I+}
|
||||
result := (IOResult = 0);
|
||||
end;
|
||||
|
||||
|
||||
{****************************************************************************
|
||||
Time Functions
|
||||
****************************************************************************}
|
||||
|
||||
Procedure GetLocalTime(var SystemTime: TSystemTime);
|
||||
var
|
||||
Regs: Registers;
|
||||
begin
|
||||
Regs.ah := $2C;
|
||||
RealIntr($21, Regs);
|
||||
SystemTime.Hour := Regs.Ch;
|
||||
SystemTime.Minute := Regs.Cl;
|
||||
SystemTime.Second := Regs.Dh;
|
||||
SystemTime.MilliSecond := Regs.Dl;
|
||||
Regs.ah := $2A;
|
||||
RealIntr($21, Regs);
|
||||
SystemTime.Year := Regs.Cx;
|
||||
SystemTime.Month := Regs.Dh;
|
||||
SystemTime.Day := Regs.Dl;
|
||||
end ;
|
||||
|
||||
|
||||
{****************************************************************************
|
||||
Misc Functions
|
||||
****************************************************************************}
|
||||
|
||||
procedure Beep;
|
||||
begin
|
||||
end;
|
||||
|
||||
|
||||
{****************************************************************************
|
||||
Locale Functions
|
||||
****************************************************************************}
|
||||
|
||||
{ Codepage constants }
|
||||
const
|
||||
CP_US = 437;
|
||||
CP_MultiLingual = 850;
|
||||
CP_SlavicLatin2 = 852;
|
||||
CP_Turkish = 857;
|
||||
CP_Portugal = 860;
|
||||
CP_IceLand = 861;
|
||||
CP_Canada = 863;
|
||||
CP_NorwayDenmark = 865;
|
||||
|
||||
{ CountryInfo }
|
||||
type
|
||||
TCountryInfo = packed record
|
||||
InfoId: byte;
|
||||
case integer of
|
||||
1: ( Size: word;
|
||||
CountryId: word;
|
||||
CodePage: word;
|
||||
CountryInfo: array[0..33] of byte );
|
||||
2: ( UpperCaseTable: longint );
|
||||
4: ( FilenameUpperCaseTable: longint );
|
||||
5: ( FilecharacterTable: longint );
|
||||
6: ( CollatingTable: longint );
|
||||
7: ( DBCSLeadByteTable: longint );
|
||||
end ;
|
||||
|
||||
|
||||
procedure GetExtendedCountryInfo(InfoId: integer; CodePage, CountryId: word; var CountryInfo: TCountryInfo);
|
||||
|
||||
Var Regs: Registers;
|
||||
|
||||
begin
|
||||
Regs.AH := $65;
|
||||
Regs.AL := InfoId;
|
||||
Regs.BX := CodePage;
|
||||
Regs.DX := CountryId;
|
||||
Regs.ES := transfer_buffer div 16;
|
||||
Regs.DI := transfer_buffer and 15;
|
||||
Regs.CX := SizeOf(TCountryInfo);
|
||||
RealIntr($21, Regs);
|
||||
DosMemGet(transfer_buffer div 16,
|
||||
transfer_buffer and 15,
|
||||
CountryInfo, Regs.CX );
|
||||
end;
|
||||
|
||||
|
||||
procedure InitAnsi;
|
||||
var
|
||||
CountryInfo: TCountryInfo; i: integer;
|
||||
begin
|
||||
{ Fill table entries 0 to 127 }
|
||||
for i := 0 to 96 do
|
||||
UpperCaseTable[i] := chr(i);
|
||||
for i := 97 to 122 do
|
||||
UpperCaseTable[i] := chr(i - 32);
|
||||
for i := 123 to 127 do
|
||||
UpperCaseTable[i] := chr(i);
|
||||
for i := 0 to 64 do
|
||||
LowerCaseTable[i] := chr(i);
|
||||
for i := 65 to 90 do
|
||||
LowerCaseTable[i] := chr(i + 32);
|
||||
for i := 91 to 255 do
|
||||
LowerCaseTable[i] := chr(i);
|
||||
|
||||
{ Get country and codepage info }
|
||||
GetExtendedCountryInfo(1, $FFFF, $FFFF, CountryInfo);
|
||||
if CountryInfo.CodePage = 850 then
|
||||
begin
|
||||
{ Special, known case }
|
||||
Move(CP850UCT, UpperCaseTable[128], 128);
|
||||
Move(CP850LCT, LowerCaseTable[128], 128);
|
||||
end
|
||||
else
|
||||
begin
|
||||
{ this needs to be checked !!
|
||||
this is correct only if UpperCaseTable is
|
||||
and Offset:Segment word record (PM) }
|
||||
{ get the uppercase table from dosmemory }
|
||||
GetExtendedCountryInfo(2, $FFFF, $FFFF, CountryInfo);
|
||||
DosMemGet(CountryInfo.UpperCaseTable shr 16, 2 + CountryInfo.UpperCaseTable and 65535, UpperCaseTable[128], 128);
|
||||
for i := 128 to 255 do
|
||||
begin
|
||||
if UpperCaseTable[i] <> chr(i) then
|
||||
LowerCaseTable[ord(UpperCaseTable[i])] := chr(i);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
Procedure InitInternational;
|
||||
begin
|
||||
InitAnsi;
|
||||
end;
|
||||
|
||||
|
||||
{****************************************************************************
|
||||
Initialization code
|
||||
****************************************************************************}
|
||||
|
||||
Initialization
|
||||
InitExceptions; { Initialize exceptions. OS independent }
|
||||
InitInternational; { Initialize internationalization settings }
|
||||
Finalization
|
||||
OutOfMemory.Free;
|
||||
InValidPointer.Free;
|
||||
end.
|
||||
{
|
||||
$Log$
|
||||
Revision 1.2 2000-08-20 15:46:46 peter
|
||||
* sysutils.pp moved to target and merged with disk.inc, filutil.inc
|
||||
|
||||
}
|
||||
@ -1,5 +1,5 @@
|
||||
#
|
||||
# Makefile generated by fpcmake v1.00 [2000/07/11]
|
||||
# Makefile generated by fpcmake v1.00 [2000/08/14]
|
||||
#
|
||||
|
||||
defaultrule: all
|
||||
@ -928,7 +928,7 @@ ifdef INSTALLPPUFILES
|
||||
ifdef PPUFILES
|
||||
INSTALLPPULINKFILES:=$(shell $(PPUFILES) -S -O $(INSTALLPPUFILES))
|
||||
else
|
||||
INSTALLPPULINKFILES:=$(wildcard $(subst $(PPUEXT),$(OEXT),$(INSTALLPPUFILES)))
|
||||
INSTALLPPULINKFILES:=$(wildcard $(subst $(PPUEXT),$(OEXT),$(INSTALLPPUFILES)) $(addprefix $(LIBPREFIX),$(subst $(PPUEXT),$(STATICLIBEXT),$(INSTALLPPUFILES))))
|
||||
endif
|
||||
endif
|
||||
|
||||
@ -1093,7 +1093,7 @@ ifdef CLEANPPUFILES
|
||||
ifdef PPUFILES
|
||||
CLEANPPULINKFILES:=$(shell $(PPUFILES) $(CLEANPPUFILES))
|
||||
else
|
||||
CLEANPPULINKFILES:=$(wildcard $(subst $(PPUEXT),$(OEXT),$(CLEANPPUFILES)))
|
||||
CLEANPPULINKFILES:=$(wildcard $(subst $(PPUEXT),$(OEXT),$(CLEANPPUFILES)) $(addprefix $(LIBPREFIX),$(subst $(PPUEXT),$(STATICLIBEXT),$(CLEANPPUFILES))))
|
||||
endif
|
||||
endif
|
||||
|
||||
@ -1251,7 +1251,7 @@ ports$(PPUEXT) : ports.pp linux$(PPUEXT) objpas$(PPUEXT)
|
||||
|
||||
dl$(PPUEXT) : dl.pp
|
||||
|
||||
dynlibs$(PPUEXT) : $(INC)/dynlibs.pp dynlibs.inc dl$(PPUEXT)
|
||||
dynlibs$(PPUEXT) : $(INC)/dynlibs.pp dynlibs.inc dl$(PPUEXT) objpas$(PPUEXT)
|
||||
|
||||
|
||||
#
|
||||
@ -1285,9 +1285,9 @@ ggigraph$(PPUEXT) : ggigraph.pp linux$(PPUEXT) $(SYSTEMPPU) \
|
||||
# Delphi Compatible Units
|
||||
#
|
||||
|
||||
sysutils$(PPUEXT) : $(OBJPASDIR)/sysutils.pp $(wildcard $(OBJPASDIR)/*.inc) \
|
||||
sysutils$(PPUEXT) : sysutils.pp $(wildcard $(OBJPASDIR)/*.inc) \
|
||||
filutil.inc disk.inc objpas$(PPUEXT) linux$(PPUEXT)
|
||||
$(COMPILER) -I$(OBJPASDIR) $(OBJPASDIR)/sysutils.pp $(REDIR)
|
||||
$(COMPILER) -I$(OBJPASDIR) sysutils.pp $(REDIR)
|
||||
|
||||
typinfo$(PPUEXT): $(OBJPASDIR)/typinfo.pp objpas$(PPUEXT)
|
||||
$(COMPILER) -Sg $(OBJPASDIR)/typinfo.pp $(REDIR)
|
||||
|
||||
@ -166,9 +166,9 @@ ggigraph$(PPUEXT) : ggigraph.pp linux$(PPUEXT) $(SYSTEMPPU) \
|
||||
# Delphi Compatible Units
|
||||
#
|
||||
|
||||
sysutils$(PPUEXT) : $(OBJPASDIR)/sysutils.pp $(wildcard $(OBJPASDIR)/*.inc) \
|
||||
sysutils$(PPUEXT) : sysutils.pp $(wildcard $(OBJPASDIR)/*.inc) \
|
||||
filutil.inc disk.inc objpas$(PPUEXT) linux$(PPUEXT)
|
||||
$(COMPILER) -I$(OBJPASDIR) $(OBJPASDIR)/sysutils.pp $(REDIR)
|
||||
$(COMPILER) -I$(OBJPASDIR) sysutils.pp $(REDIR)
|
||||
|
||||
typinfo$(PPUEXT): $(OBJPASDIR)/typinfo.pp objpas$(PPUEXT)
|
||||
$(COMPILER) -Sg $(OBJPASDIR)/typinfo.pp $(REDIR)
|
||||
|
||||
@ -1,120 +0,0 @@
|
||||
{
|
||||
$Id$
|
||||
This file is part of the Free Pascal run time library.
|
||||
Copyright (c) 1999-2000 by the Free Pascal development team
|
||||
|
||||
Disk functions from Delphi's sysutils.pas
|
||||
|
||||
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.
|
||||
|
||||
**********************************************************************}
|
||||
|
||||
{
|
||||
The Diskfree and Disksize functions need a file on the specified drive, since this
|
||||
is required for the statfs system call.
|
||||
These filenames are set in drivestr[0..26], and have been preset to :
|
||||
0 - '.' (default drive - hence current dir is ok.)
|
||||
1 - '/fd0/.' (floppy drive 1 - should be adapted to local system )
|
||||
2 - '/fd1/.' (floppy drive 2 - should be adapted to local system )
|
||||
3 - '/' (C: equivalent of dos is the root partition)
|
||||
4..26 (can be set by you're own applications)
|
||||
! Use AddDisk() to Add new drives !
|
||||
They both return -1 when a failure occurs.
|
||||
}
|
||||
Const
|
||||
FixDriveStr : array[0..3] of pchar=(
|
||||
'.',
|
||||
'/fd0/.',
|
||||
'/fd1/.',
|
||||
'/.'
|
||||
);
|
||||
var
|
||||
Drives : byte;
|
||||
DriveStr : array[4..26] of pchar;
|
||||
|
||||
Procedure AddDisk(const path:string);
|
||||
begin
|
||||
if not (DriveStr[Drives]=nil) then
|
||||
FreeMem(DriveStr[Drives],StrLen(DriveStr[Drives])+1);
|
||||
GetMem(DriveStr[Drives],length(Path)+1);
|
||||
StrPCopy(DriveStr[Drives],path);
|
||||
inc(Drives);
|
||||
if Drives>26 then
|
||||
Drives:=4;
|
||||
end;
|
||||
|
||||
|
||||
|
||||
|
||||
Function DiskFree(Drive: Byte): int64;
|
||||
var
|
||||
fs : statfs;
|
||||
Begin
|
||||
if ((Drive<4) and (not (fixdrivestr[Drive]=nil)) and fsstat(StrPas(fixdrivestr[drive]),fs)) or
|
||||
((not (drivestr[Drive]=nil)) and fsstat(StrPas(drivestr[drive]),fs)) then
|
||||
Diskfree:=int64(fs.bavail)*int64(fs.bsize)
|
||||
else
|
||||
Diskfree:=-1;
|
||||
End;
|
||||
|
||||
|
||||
|
||||
Function DiskSize(Drive: Byte): int64;
|
||||
var
|
||||
fs : statfs;
|
||||
Begin
|
||||
if ((Drive<4) and (not (fixdrivestr[Drive]=nil)) and fsstat(StrPas(fixdrivestr[drive]),fs)) or
|
||||
((not (drivestr[Drive]=nil)) and fsstat(StrPas(drivestr[drive]),fs)) then
|
||||
DiskSize:=int64(fs.blocks)*int64(fs.bsize)
|
||||
else
|
||||
DiskSize:=-1;
|
||||
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;
|
||||
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.3 2000-07-14 10:33:10 michael
|
||||
+ Conditionals fixed
|
||||
|
||||
Revision 1.2 2000/07/13 11:33:48 michael
|
||||
+ removed logs
|
||||
|
||||
}
|
||||
@ -1,9 +1,10 @@
|
||||
{
|
||||
$Id$
|
||||
This file is part of the Free Pascal run time library.
|
||||
Copyright (c) 1999-2000 by the Free Pascal development team
|
||||
Copyright (c) 1999-2000 by Florian Klaempfl
|
||||
member of the Free Pascal development team
|
||||
|
||||
File utility calls
|
||||
Sysutils unit for linux
|
||||
|
||||
See the file COPYING.FPC, included in this distribution,
|
||||
for details about the copyright.
|
||||
@ -13,7 +14,29 @@
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
|
||||
|
||||
**********************************************************************}
|
||||
unit sysutils;
|
||||
interface
|
||||
|
||||
{$MODE objfpc}
|
||||
{ force ansistrings }
|
||||
{$H+}
|
||||
|
||||
uses
|
||||
linux;
|
||||
|
||||
{ Include platform independent interface part }
|
||||
{$i sysutilh.inc}
|
||||
|
||||
|
||||
implementation
|
||||
|
||||
{ Include platform independent implementation part }
|
||||
{$i sysutils.inc}
|
||||
|
||||
|
||||
{****************************************************************************
|
||||
File Functions
|
||||
****************************************************************************}
|
||||
|
||||
Function FileOpen (Const FileName : string; Mode : Integer) : Longint;
|
||||
|
||||
@ -95,10 +118,9 @@ begin
|
||||
FileExists:=fstat(filename,Info);
|
||||
end;
|
||||
|
||||
|
||||
Function LinuxToWinAttr (FN : Char; Const Info : Stat) : Longint;
|
||||
|
||||
|
||||
|
||||
begin
|
||||
Result:=faArchive;
|
||||
If FN='.' then
|
||||
@ -107,9 +129,9 @@ begin
|
||||
Result:=Result or faDirectory;
|
||||
If (Info.Mode and STAT_IWUSR)=0 Then
|
||||
Result:=Result or faReadOnly;
|
||||
If (Info.Mode and
|
||||
If (Info.Mode and
|
||||
(STAT_IFSOCK or STAT_IFBLK or STAT_IFCHR or STAT_IFIFO))<>0 then
|
||||
Result:=Result or faSysFile;
|
||||
Result:=Result or faSysFile;
|
||||
end;
|
||||
|
||||
{
|
||||
@ -244,46 +266,168 @@ begin
|
||||
FileSearch:=Linux.FSearch(Name,Dirlist);
|
||||
end;
|
||||
|
||||
Procedure GetLocalTime(var SystemTime: TSystemTime);
|
||||
|
||||
begin
|
||||
linux.GetTime(SystemTime.Hour, SystemTime.Minute, SystemTime.Second);
|
||||
linux.GetDate(SystemTime.Year, SystemTime.Month, SystemTime.Day);
|
||||
SystemTime.MilliSecond := 0;
|
||||
end ;
|
||||
|
||||
Procedure InitAnsi;
|
||||
|
||||
Var i : longint;
|
||||
|
||||
begin
|
||||
{ Fill table entries 0 to 127 }
|
||||
for i := 0 to 96 do
|
||||
UpperCaseTable[i] := chr(i);
|
||||
for i := 97 to 122 do
|
||||
UpperCaseTable[i] := chr(i - 32);
|
||||
for i := 123 to 191 do
|
||||
UpperCaseTable[i] := chr(i);
|
||||
Move (CPISO88591UCT,UpperCaseTable[192],SizeOf(CPISO88591UCT));
|
||||
|
||||
for i := 0 to 64 do
|
||||
LowerCaseTable[i] := chr(i);
|
||||
for i := 65 to 90 do
|
||||
LowerCaseTable[i] := chr(i + 32);
|
||||
for i := 91 to 191 do
|
||||
LowerCaseTable[i] := chr(i);
|
||||
Move (CPISO88591LCT,UpperCaseTable[192],SizeOf(CPISO88591UCT));
|
||||
end;
|
||||
|
||||
Procedure InitInternational;
|
||||
|
||||
begin
|
||||
InitAnsi;
|
||||
end;
|
||||
{****************************************************************************
|
||||
Disk Functions
|
||||
****************************************************************************}
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.2 2000-07-13 11:33:48 michael
|
||||
+ removed logs
|
||||
|
||||
The Diskfree and Disksize functions need a file on the specified drive, since this
|
||||
is required for the statfs system call.
|
||||
These filenames are set in drivestr[0..26], and have been preset to :
|
||||
0 - '.' (default drive - hence current dir is ok.)
|
||||
1 - '/fd0/.' (floppy drive 1 - should be adapted to local system )
|
||||
2 - '/fd1/.' (floppy drive 2 - should be adapted to local system )
|
||||
3 - '/' (C: equivalent of dos is the root partition)
|
||||
4..26 (can be set by you're own applications)
|
||||
! Use AddDisk() to Add new drives !
|
||||
They both return -1 when a failure occurs.
|
||||
}
|
||||
Const
|
||||
FixDriveStr : array[0..3] of pchar=(
|
||||
'.',
|
||||
'/fd0/.',
|
||||
'/fd1/.',
|
||||
'/.'
|
||||
);
|
||||
var
|
||||
Drives : byte;
|
||||
DriveStr : array[4..26] of pchar;
|
||||
|
||||
Procedure AddDisk(const path:string);
|
||||
begin
|
||||
if not (DriveStr[Drives]=nil) then
|
||||
FreeMem(DriveStr[Drives],StrLen(DriveStr[Drives])+1);
|
||||
GetMem(DriveStr[Drives],length(Path)+1);
|
||||
StrPCopy(DriveStr[Drives],path);
|
||||
inc(Drives);
|
||||
if Drives>26 then
|
||||
Drives:=4;
|
||||
end;
|
||||
|
||||
|
||||
Function DiskFree(Drive: Byte): int64;
|
||||
var
|
||||
fs : statfs;
|
||||
Begin
|
||||
if ((Drive<4) and (not (fixdrivestr[Drive]=nil)) and fsstat(StrPas(fixdrivestr[drive]),fs)) or
|
||||
((not (drivestr[Drive]=nil)) and fsstat(StrPas(drivestr[drive]),fs)) then
|
||||
Diskfree:=int64(fs.bavail)*int64(fs.bsize)
|
||||
else
|
||||
Diskfree:=-1;
|
||||
End;
|
||||
|
||||
|
||||
|
||||
Function DiskSize(Drive: Byte): int64;
|
||||
var
|
||||
fs : statfs;
|
||||
Begin
|
||||
if ((Drive<4) and (not (fixdrivestr[Drive]=nil)) and fsstat(StrPas(fixdrivestr[drive]),fs)) or
|
||||
((not (drivestr[Drive]=nil)) and fsstat(StrPas(drivestr[drive]),fs)) then
|
||||
DiskSize:=int64(fs.blocks)*int64(fs.bsize)
|
||||
else
|
||||
DiskSize:=-1;
|
||||
End;
|
||||
|
||||
|
||||
Function GetCurrentDir : String;
|
||||
begin
|
||||
GetDir (0,Result);
|
||||
end;
|
||||
|
||||
|
||||
Function SetCurrentDir (Const NewDir : String) : Boolean;
|
||||
begin
|
||||
{$I-}
|
||||
ChDir(NewDir);
|
||||
{$I+}
|
||||
result := (IOResult = 0);
|
||||
end;
|
||||
|
||||
|
||||
Function CreateDir (Const NewDir : String) : Boolean;
|
||||
begin
|
||||
{$I-}
|
||||
MkDir(NewDir);
|
||||
{$I+}
|
||||
result := (IOResult = 0);
|
||||
end;
|
||||
|
||||
|
||||
Function RemoveDir (Const Dir : String) : Boolean;
|
||||
begin
|
||||
{$I-}
|
||||
RmDir(Dir);
|
||||
{$I+}
|
||||
result := (IOResult = 0);
|
||||
end;
|
||||
|
||||
|
||||
{****************************************************************************
|
||||
Misc Functions
|
||||
****************************************************************************}
|
||||
|
||||
procedure Beep;
|
||||
begin
|
||||
end;
|
||||
|
||||
|
||||
{****************************************************************************
|
||||
Locale Functions
|
||||
****************************************************************************}
|
||||
|
||||
Procedure GetLocalTime(var SystemTime: TSystemTime);
|
||||
begin
|
||||
linux.GetTime(SystemTime.Hour, SystemTime.Minute, SystemTime.Second);
|
||||
linux.GetDate(SystemTime.Year, SystemTime.Month, SystemTime.Day);
|
||||
SystemTime.MilliSecond := 0;
|
||||
end ;
|
||||
|
||||
|
||||
Procedure InitAnsi;
|
||||
Var
|
||||
i : longint;
|
||||
begin
|
||||
{ Fill table entries 0 to 127 }
|
||||
for i := 0 to 96 do
|
||||
UpperCaseTable[i] := chr(i);
|
||||
for i := 97 to 122 do
|
||||
UpperCaseTable[i] := chr(i - 32);
|
||||
for i := 123 to 191 do
|
||||
UpperCaseTable[i] := chr(i);
|
||||
Move (CPISO88591UCT,UpperCaseTable[192],SizeOf(CPISO88591UCT));
|
||||
|
||||
for i := 0 to 64 do
|
||||
LowerCaseTable[i] := chr(i);
|
||||
for i := 65 to 90 do
|
||||
LowerCaseTable[i] := chr(i + 32);
|
||||
for i := 91 to 191 do
|
||||
LowerCaseTable[i] := chr(i);
|
||||
Move (CPISO88591LCT,UpperCaseTable[192],SizeOf(CPISO88591UCT));
|
||||
end;
|
||||
|
||||
|
||||
Procedure InitInternational;
|
||||
begin
|
||||
InitAnsi;
|
||||
end;
|
||||
|
||||
|
||||
{****************************************************************************
|
||||
Initialization code
|
||||
****************************************************************************}
|
||||
|
||||
Initialization
|
||||
InitExceptions; { Initialize exceptions. OS independent }
|
||||
InitInternational; { Initialize internationalization settings }
|
||||
Finalization
|
||||
OutOfMemory.Free;
|
||||
InValidPointer.Free;
|
||||
end.
|
||||
{
|
||||
$Log$
|
||||
Revision 1.2 2000-08-20 15:46:46 peter
|
||||
* sysutils.pp moved to target and merged with disk.inc, filutil.inc
|
||||
|
||||
}
|
||||
@ -101,12 +101,14 @@ function StrToDateTime(const S: string): TDateTime;
|
||||
function FormatDateTime(FormatStr: string; DateTime: TDateTime):string;
|
||||
procedure DateTimeToString(var Result: string; const FormatStr: string; const DateTime: TDateTime);
|
||||
Function DateTimeToFileDate(DateTime : TDateTime) : Longint;
|
||||
Function FileDateToDateTime (Filedate : Longint) : TDateTime;
|
||||
Function FileDateToDateTime (Filedate : Longint) :TDateTime;
|
||||
|
||||
{ FPC Extra }
|
||||
Procedure GetLocalTime(var SystemTime: TSystemTime);
|
||||
|
||||
{
|
||||
|
||||
$Log$
|
||||
Revision 1.2 2000-07-13 11:33:51 michael
|
||||
+ removed logs
|
||||
|
||||
Revision 1.3 2000-08-20 15:46:46 peter
|
||||
* sysutils.pp moved to target and merged with disk.inc, filutil.inc
|
||||
|
||||
}
|
||||
|
||||
136
rtl/objpas/sysutilh.inc
Normal file
136
rtl/objpas/sysutilh.inc
Normal file
@ -0,0 +1,136 @@
|
||||
{
|
||||
$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
|
||||
|
||||
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.
|
||||
|
||||
**********************************************************************}
|
||||
|
||||
|
||||
{ Read String Handling functions declaration }
|
||||
{$i sysstrh.inc}
|
||||
|
||||
type
|
||||
{ some helpful data types }
|
||||
|
||||
tprocedure = procedure;
|
||||
|
||||
tfilename = string;
|
||||
|
||||
tsyscharset = set of char;
|
||||
|
||||
longrec = packed record
|
||||
lo,hi : word;
|
||||
end;
|
||||
|
||||
wordrec = packed record
|
||||
lo,hi : byte;
|
||||
end;
|
||||
|
||||
TMethod = packed record
|
||||
Code, Data: Pointer;
|
||||
end;
|
||||
|
||||
{ exceptions }
|
||||
Exception = class(TObject)
|
||||
private
|
||||
fmessage : string;
|
||||
fhelpcontext : longint;
|
||||
public
|
||||
constructor Create(const msg : string);
|
||||
constructor CreateFmt(const msg : string; const args : array of const);
|
||||
constructor CreateRes(ResString: PString);
|
||||
constructor CreateResFmt(ResString: PString; const Args: array of const);
|
||||
constructor CreateHelp(const Msg: string; AHelpContext: Integer);
|
||||
constructor CreateFmtHelp(const Msg: string; const Args: array of const;
|
||||
AHelpContext: Integer);
|
||||
constructor CreateResHelp(ResString: PString; AHelpContext: Integer);
|
||||
constructor CreateResFmtHelp(ResString: PString; const Args: array of const;
|
||||
AHelpContext: Integer);
|
||||
{ !!!! }
|
||||
property helpcontext : longint read fhelpcontext write fhelpcontext;
|
||||
property message : string read fmessage write fmessage;
|
||||
end;
|
||||
|
||||
ExceptClass = class of Exception;
|
||||
|
||||
{ integer math exceptions }
|
||||
EInterror = Class(Exception);
|
||||
EDivByZero = Class(EIntError);
|
||||
ERangeError = Class(EIntError);
|
||||
EIntOverflow = Class(EIntError);
|
||||
|
||||
{ General math errors }
|
||||
EMathError = Class(Exception);
|
||||
EInvalidOp = Class(EMathError);
|
||||
EZeroDivide = Class(EMathError);
|
||||
EOverflow = Class(EMathError);
|
||||
EUnderflow = Class(EMathError);
|
||||
|
||||
{ Run-time and I/O Errors }
|
||||
EInOutError = class(Exception)
|
||||
public
|
||||
ErrorCode : Longint;
|
||||
end;
|
||||
EInvalidPointer = Class(Exception);
|
||||
EOutOfMemory = Class(Exception);
|
||||
EAccessViolation = Class(Exception);
|
||||
EInvalidCast = Class(Exception);
|
||||
|
||||
|
||||
{ String conversion errors }
|
||||
EConvertError = class(Exception);
|
||||
|
||||
{ Other errors }
|
||||
EAbort = Class(Exception);
|
||||
EAbstractError = Class(Exception);
|
||||
EAssertionFailed = Class(Exception);
|
||||
|
||||
{ Exception handling routines }
|
||||
function ExceptObject: TObject;
|
||||
function ExceptAddr: Pointer;
|
||||
function ExceptionErrorMessage(ExceptObject: TObject; ExceptAddr: Pointer;
|
||||
Buffer: PChar; Size: Integer): Integer;
|
||||
procedure ShowException(ExceptObject: TObject; ExceptAddr: Pointer);
|
||||
procedure Abort;
|
||||
procedure OutOfMemoryError;
|
||||
procedure Beep;
|
||||
|
||||
Var
|
||||
OnShowException : Procedure (Msg : ShortString);
|
||||
|
||||
{ FileRec/TextRec }
|
||||
{$i filerec.inc}
|
||||
{$i textrec.inc}
|
||||
|
||||
{ Read internationalization settings }
|
||||
{$i sysinth.inc}
|
||||
|
||||
{ Read date & Time function declarations }
|
||||
{$i datih.inc}
|
||||
|
||||
{ Read pchar handling functions declration }
|
||||
{$i syspchh.inc}
|
||||
|
||||
{ Read filename handling functions declaration }
|
||||
{$i finah.inc}
|
||||
|
||||
{ Read other file handling function declarations }
|
||||
{$i filutilh.inc}
|
||||
|
||||
{ Read disk function declarations }
|
||||
{$i diskh.inc}
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.2 2000-08-20 15:46:46 peter
|
||||
* sysutils.pp moved to target and merged with disk.inc, filutil.inc
|
||||
|
||||
}
|
||||
@ -12,147 +12,6 @@
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
|
||||
|
||||
**********************************************************************}
|
||||
unit sysutils;
|
||||
interface
|
||||
|
||||
{$MODE objfpc}
|
||||
{ force ansistrings }
|
||||
{$H+}
|
||||
|
||||
uses
|
||||
{$ifdef linux}
|
||||
linux
|
||||
{$endif}
|
||||
{$ifdef win32}
|
||||
dos,windows
|
||||
{$endif}
|
||||
{$ifdef go32v1}
|
||||
go32,dos
|
||||
{$endif}
|
||||
{$ifdef go32v2}
|
||||
go32,dos
|
||||
{$endif}
|
||||
{$ifdef os2}
|
||||
doscalls,dos
|
||||
{$endif}
|
||||
;
|
||||
|
||||
|
||||
{ Read String Handling functions declaration }
|
||||
{$i sysstrh.inc}
|
||||
|
||||
type
|
||||
{ some helpful data types }
|
||||
|
||||
tprocedure = procedure;
|
||||
|
||||
tfilename = string;
|
||||
|
||||
tsyscharset = set of char;
|
||||
|
||||
longrec = packed record
|
||||
lo,hi : word;
|
||||
end;
|
||||
|
||||
wordrec = packed record
|
||||
lo,hi : byte;
|
||||
end;
|
||||
|
||||
TMethod = packed record
|
||||
Code, Data: Pointer;
|
||||
end;
|
||||
|
||||
{ exceptions }
|
||||
Exception = class(TObject)
|
||||
private
|
||||
fmessage : string;
|
||||
fhelpcontext : longint;
|
||||
public
|
||||
constructor Create(const msg : string);
|
||||
constructor CreateFmt(const msg : string; const args : array of const);
|
||||
constructor CreateRes(ResString: PString);
|
||||
constructor CreateResFmt(ResString: PString; const Args: array of const);
|
||||
constructor CreateHelp(const Msg: string; AHelpContext: Integer);
|
||||
constructor CreateFmtHelp(const Msg: string; const Args: array of const;
|
||||
AHelpContext: Integer);
|
||||
constructor CreateResHelp(ResString: PString; AHelpContext: Integer);
|
||||
constructor CreateResFmtHelp(ResString: PString; const Args: array of const;
|
||||
AHelpContext: Integer);
|
||||
{ !!!! }
|
||||
property helpcontext : longint read fhelpcontext write fhelpcontext;
|
||||
property message : string read fmessage write fmessage;
|
||||
end;
|
||||
|
||||
ExceptClass = class of Exception;
|
||||
|
||||
{ integer math exceptions }
|
||||
EInterror = Class(Exception);
|
||||
EDivByZero = Class(EIntError);
|
||||
ERangeError = Class(EIntError);
|
||||
EIntOverflow = Class(EIntError);
|
||||
|
||||
{ General math errors }
|
||||
EMathError = Class(Exception);
|
||||
EInvalidOp = Class(EMathError);
|
||||
EZeroDivide = Class(EMathError);
|
||||
EOverflow = Class(EMathError);
|
||||
EUnderflow = Class(EMathError);
|
||||
|
||||
{ Run-time and I/O Errors }
|
||||
EInOutError = class(Exception)
|
||||
public
|
||||
ErrorCode : Longint;
|
||||
end;
|
||||
EInvalidPointer = Class(Exception);
|
||||
EOutOfMemory = Class(Exception);
|
||||
EAccessViolation = Class(Exception);
|
||||
EInvalidCast = Class(Exception);
|
||||
|
||||
|
||||
{ String conversion errors }
|
||||
EConvertError = class(Exception);
|
||||
|
||||
{ Other errors }
|
||||
EAbort = Class(Exception);
|
||||
EAbstractError = Class(Exception);
|
||||
EAssertionFailed = Class(Exception);
|
||||
|
||||
{ Exception handling routines }
|
||||
function ExceptObject: TObject;
|
||||
function ExceptAddr: Pointer;
|
||||
function ExceptionErrorMessage(ExceptObject: TObject; ExceptAddr: Pointer;
|
||||
Buffer: PChar; Size: Integer): Integer;
|
||||
procedure ShowException(ExceptObject: TObject; ExceptAddr: Pointer);
|
||||
procedure Abort;
|
||||
procedure OutOfMemoryError;
|
||||
procedure Beep;
|
||||
|
||||
Var
|
||||
OnShowException : Procedure (Msg : ShortString);
|
||||
|
||||
{ FileRec/TextRec }
|
||||
{$i filerec.inc}
|
||||
{$i textrec.inc}
|
||||
|
||||
{ Read internationalization settings }
|
||||
{$i sysinth.inc}
|
||||
|
||||
{ Read date & Time function declarations }
|
||||
{$i datih.inc}
|
||||
|
||||
{ Read pchar handling functions declration }
|
||||
{$i syspchh.inc}
|
||||
|
||||
{ Read filename handling functions declaration }
|
||||
{$i finah.inc}
|
||||
|
||||
{ Read other file handling function declarations }
|
||||
{$i filutilh.inc}
|
||||
|
||||
{ Read disk function declarations }
|
||||
{$i diskh.inc}
|
||||
|
||||
implementation
|
||||
|
||||
{ Read message string definitions }
|
||||
{
|
||||
@ -172,12 +31,6 @@ Var
|
||||
{ Read String Handling functions implementation }
|
||||
{$i sysstr.inc}
|
||||
|
||||
{ Read other file handling function implementations }
|
||||
{$i filutil.inc}
|
||||
|
||||
{ Read disk function implementations }
|
||||
{$i disk.inc}
|
||||
|
||||
{ Read date & Time function implementations }
|
||||
{$i dati.inc}
|
||||
|
||||
@ -328,7 +181,7 @@ begin
|
||||
else
|
||||
E:=Exception.CreateFmt (SUnKnownRunTimeError,[Errno]);
|
||||
end;
|
||||
Raise E at longint(Address),longint(Frame);
|
||||
Raise E at longint(Address){$ifdef ENHANCEDRAISE},longint(Frame){$endif};
|
||||
end;
|
||||
|
||||
|
||||
@ -434,39 +287,9 @@ begin
|
||||
Raise OutOfMemory;
|
||||
end;
|
||||
|
||||
procedure Beep;
|
||||
|
||||
begin
|
||||
{$ifdef win32}
|
||||
MessageBeep(0);
|
||||
{$else}
|
||||
|
||||
{$endif}
|
||||
end;
|
||||
|
||||
{ Initialization code. }
|
||||
|
||||
Initialization
|
||||
InitExceptions; { Initialize exceptions. OS independent }
|
||||
InitInternational; { Initialize internationalization settings }
|
||||
Finalization
|
||||
OutOfMemory.Free;
|
||||
InValidPointer.Free;
|
||||
end.
|
||||
{
|
||||
$Log$
|
||||
Revision 1.5 2000-08-06 14:19:06 peter
|
||||
* overload directives removed (merged)
|
||||
|
||||
Revision 1.4 2000/07/27 16:20:52 sg
|
||||
* Applied patch by Markus Kaemmerer with minor modifications: More methods
|
||||
of the Exception class are now implemented (in a manner so that they can
|
||||
be used as in Delphi, although the declarations are somewhat different)
|
||||
|
||||
Revision 1.3 2000/07/14 10:33:10 michael
|
||||
+ Conditionals fixed
|
||||
|
||||
Revision 1.2 2000/07/13 11:33:51 michael
|
||||
+ removed logs
|
||||
Revision 1.2 2000-08-20 15:46:46 peter
|
||||
* sysutils.pp moved to target and merged with disk.inc, filutil.inc
|
||||
|
||||
}
|
||||
@ -1,5 +1,5 @@
|
||||
#
|
||||
# Makefile generated by fpcmake v0.99.15 [2000/07/02]
|
||||
# Makefile generated by fpcmake v1.00 [2000/08/14]
|
||||
#
|
||||
|
||||
defaultrule: all
|
||||
@ -916,7 +916,7 @@ ifdef INSTALLPPUFILES
|
||||
ifdef PPUFILES
|
||||
INSTALLPPULINKFILES:=$(shell $(PPUFILES) -S -O $(INSTALLPPUFILES))
|
||||
else
|
||||
INSTALLPPULINKFILES:=$(wildcard $(subst $(PPUEXT),$(OEXT),$(INSTALLPPUFILES)))
|
||||
INSTALLPPULINKFILES:=$(wildcard $(subst $(PPUEXT),$(OEXT),$(INSTALLPPUFILES)) $(addprefix $(LIBPREFIX),$(subst $(PPUEXT),$(STATICLIBEXT),$(INSTALLPPUFILES))))
|
||||
endif
|
||||
endif
|
||||
|
||||
@ -1081,7 +1081,7 @@ ifdef CLEANPPUFILES
|
||||
ifdef PPUFILES
|
||||
CLEANPPULINKFILES:=$(shell $(PPUFILES) $(CLEANPPUFILES))
|
||||
else
|
||||
CLEANPPULINKFILES:=$(wildcard $(subst $(PPUEXT),$(OEXT),$(CLEANPPUFILES)))
|
||||
CLEANPPULINKFILES:=$(wildcard $(subst $(PPUEXT),$(OEXT),$(CLEANPPUFILES)) $(addprefix $(LIBPREFIX),$(subst $(PPUEXT),$(STATICLIBEXT),$(CLEANPPUFILES))))
|
||||
endif
|
||||
endif
|
||||
|
||||
@ -1246,7 +1246,7 @@ dive$(PPUEXT) : dive.pas os2def$(PPUEXT) pmwin$(PPUEXT) $(SYSTEMPPU)
|
||||
#
|
||||
|
||||
dos$(PPUEXT) : dos.pas $(INC)/filerec.inc $(INC)/textrec.inc strings$(PPUEXT) \
|
||||
$(SYSTEMPPU)
|
||||
doscalls$(PPUEXT) $(SYSTEMPPU)
|
||||
|
||||
crt$(PPUEXT) : crt.pas $(INC)/textrec.inc $(SYSTEMPPU)
|
||||
|
||||
@ -1260,9 +1260,9 @@ printer$(PPUEXT) : printer.pas $(INC)/textrec.inc $(SYSTEMPPU)
|
||||
# Delphi Compatible Units
|
||||
#
|
||||
|
||||
sysutils$(PPUEXT) : $(OBJPASDIR)/sysutils.pp $(wildcard $(OBJPASDIR)/*.inc) \
|
||||
filutil.inc disk.inc objpas$(PPUEXT)
|
||||
$(COMPILER) -I$(OBJPASDIR) $(OBJPASDIR)/sysutils.pp $(REDIR)
|
||||
sysutils$(PPUEXT) : sysutils.pp $(wildcard $(OBJPASDIR)/*.inc) \
|
||||
objpas$(PPUEXT) dos$(PPUEXT) doscalls$(PPUEXT)
|
||||
$(COMPILER) -I$(OBJPASDIR) sysutils.pp $(REDIR)
|
||||
|
||||
typinfo$(PPUEXT): $(OBJPASDIR)/typinfo.pp objpas$(PPUEXT)
|
||||
$(COMPILER) -Sg $(OBJPASDIR)/typinfo.pp $(REDIR)
|
||||
|
||||
@ -119,7 +119,7 @@ dive$(PPUEXT) : dive.pas os2def$(PPUEXT) pmwin$(PPUEXT) $(SYSTEMPPU)
|
||||
#
|
||||
|
||||
dos$(PPUEXT) : dos.pas $(INC)/filerec.inc $(INC)/textrec.inc strings$(PPUEXT) \
|
||||
$(SYSTEMPPU)
|
||||
doscalls$(PPUEXT) $(SYSTEMPPU)
|
||||
|
||||
crt$(PPUEXT) : crt.pas $(INC)/textrec.inc $(SYSTEMPPU)
|
||||
|
||||
@ -133,9 +133,9 @@ printer$(PPUEXT) : printer.pas $(INC)/textrec.inc $(SYSTEMPPU)
|
||||
# Delphi Compatible Units
|
||||
#
|
||||
|
||||
sysutils$(PPUEXT) : $(OBJPASDIR)/sysutils.pp $(wildcard $(OBJPASDIR)/*.inc) \
|
||||
filutil.inc disk.inc objpas$(PPUEXT)
|
||||
$(COMPILER) -I$(OBJPASDIR) $(OBJPASDIR)/sysutils.pp $(REDIR)
|
||||
sysutils$(PPUEXT) : sysutils.pp $(wildcard $(OBJPASDIR)/*.inc) \
|
||||
objpas$(PPUEXT) dos$(PPUEXT) doscalls$(PPUEXT)
|
||||
$(COMPILER) -I$(OBJPASDIR) sysutils.pp $(REDIR)
|
||||
|
||||
typinfo$(PPUEXT): $(OBJPASDIR)/typinfo.pp objpas$(PPUEXT)
|
||||
$(COMPILER) -Sg $(OBJPASDIR)/typinfo.pp $(REDIR)
|
||||
|
||||
139
rtl/os2/disk.inc
139
rtl/os2/disk.inc
@ -1,139 +0,0 @@
|
||||
{
|
||||
$Id$
|
||||
This file is part of the Free Pascal run time library.
|
||||
Copyright (c) 1999-2000 by the Free Pascal development team
|
||||
|
||||
Disk functions from Delphi's sysutils.pas
|
||||
|
||||
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.
|
||||
|
||||
**********************************************************************}
|
||||
|
||||
{$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 8(%ebp),%dl
|
||||
movb $0x36,%ah
|
||||
call syscall
|
||||
cmpw $-1,%ax
|
||||
je .LDISKFREE1
|
||||
mulw %cx
|
||||
mulw %bx
|
||||
shll $16,%edx
|
||||
movw %ax,%dx
|
||||
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 8(%ebp),%dl
|
||||
movb $0x36,%ah
|
||||
call syscall
|
||||
movw %dx,%bx
|
||||
cmpw $-1,%ax
|
||||
je .LDISKSIZE1
|
||||
mulw %cx
|
||||
mulw %bx
|
||||
shll $16,%edx
|
||||
movw %ax,%dx
|
||||
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;
|
||||
|
||||
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.3 2000-07-14 10:33:10 michael
|
||||
+ Conditionals fixed
|
||||
|
||||
Revision 1.2 2000/07/13 11:33:52 michael
|
||||
+ removed logs
|
||||
|
||||
}
|
||||
@ -1,9 +1,10 @@
|
||||
{
|
||||
$Id$
|
||||
This file is part of the Free Pascal run time library.
|
||||
Copyright (c) 1999-2000 by the Free Pascal development team
|
||||
Copyright (c) 1999-2000 by Florian Klaempfl
|
||||
member of the Free Pascal development team
|
||||
|
||||
File utility calls
|
||||
Sysutils unit for OS/2
|
||||
|
||||
See the file COPYING.FPC, included in this distribution,
|
||||
for details about the copyright.
|
||||
@ -13,7 +14,29 @@
|
||||
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';
|
||||
@ -488,6 +511,128 @@ begin
|
||||
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 8(%ebp),%dl
|
||||
movb $0x36,%ah
|
||||
call syscall
|
||||
cmpw $-1,%ax
|
||||
je .LDISKFREE1
|
||||
mulw %cx
|
||||
mulw %bx
|
||||
shll $16,%edx
|
||||
movw %ax,%dx
|
||||
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 8(%ebp),%dl
|
||||
movb $0x36,%ah
|
||||
call syscall
|
||||
movw %dx,%bx
|
||||
cmpw $-1,%ax
|
||||
je .LDISKSIZE1
|
||||
mulw %cx
|
||||
mulw %bx
|
||||
shll $16,%edx
|
||||
movw %ax,%dx
|
||||
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 (DWord)!!! *)
|
||||
@ -516,6 +661,21 @@ asm
|
||||
mov al, dl
|
||||
stosd
|
||||
end;
|
||||
{$asmmode default}
|
||||
|
||||
|
||||
{****************************************************************************
|
||||
Misc Functions
|
||||
****************************************************************************}
|
||||
|
||||
procedure Beep;
|
||||
begin
|
||||
end;
|
||||
|
||||
|
||||
{****************************************************************************
|
||||
Locale Functions
|
||||
****************************************************************************}
|
||||
|
||||
procedure InitAnsi;
|
||||
var I: byte;
|
||||
@ -538,6 +698,7 @@ begin
|
||||
LowerCaseTable [Ord (UpperCaseTable [I])] := Chr (I);
|
||||
end;
|
||||
|
||||
|
||||
procedure InitInternational;
|
||||
var Country: TCountryCode;
|
||||
CtryInfo: TCountryInfo;
|
||||
@ -575,9 +736,20 @@ begin
|
||||
end;
|
||||
|
||||
|
||||
{****************************************************************************
|
||||
Initialization code
|
||||
****************************************************************************}
|
||||
|
||||
Initialization
|
||||
InitExceptions; { Initialize exceptions. OS independent }
|
||||
InitInternational; { Initialize internationalization settings }
|
||||
Finalization
|
||||
OutOfMemory.Free;
|
||||
InValidPointer.Free;
|
||||
end.
|
||||
{
|
||||
$Log$
|
||||
Revision 1.2 2000-07-13 11:33:52 michael
|
||||
+ removed logs
|
||||
|
||||
Revision 1.2 2000-08-20 15:46:46 peter
|
||||
* sysutils.pp moved to target and merged with disk.inc, filutil.inc
|
||||
|
||||
}
|
||||
@ -1,5 +1,5 @@
|
||||
#
|
||||
# Makefile generated by fpcmake v1.00 [2000/07/11]
|
||||
# Makefile generated by fpcmake v1.00 [2000/08/14]
|
||||
#
|
||||
|
||||
defaultrule: all
|
||||
@ -921,7 +921,7 @@ ifdef INSTALLPPUFILES
|
||||
ifdef PPUFILES
|
||||
INSTALLPPULINKFILES:=$(shell $(PPUFILES) -S -O $(INSTALLPPUFILES))
|
||||
else
|
||||
INSTALLPPULINKFILES:=$(wildcard $(subst $(PPUEXT),$(OEXT),$(INSTALLPPUFILES)))
|
||||
INSTALLPPULINKFILES:=$(wildcard $(subst $(PPUEXT),$(OEXT),$(INSTALLPPUFILES)) $(addprefix $(LIBPREFIX),$(subst $(PPUEXT),$(STATICLIBEXT),$(INSTALLPPUFILES))))
|
||||
endif
|
||||
endif
|
||||
|
||||
@ -1086,7 +1086,7 @@ ifdef CLEANPPUFILES
|
||||
ifdef PPUFILES
|
||||
CLEANPPULINKFILES:=$(shell $(PPUFILES) $(CLEANPPUFILES))
|
||||
else
|
||||
CLEANPPULINKFILES:=$(wildcard $(subst $(PPUEXT),$(OEXT),$(CLEANPPUFILES)))
|
||||
CLEANPPULINKFILES:=$(wildcard $(subst $(PPUEXT),$(OEXT),$(CLEANPPUFILES)) $(addprefix $(LIBPREFIX),$(subst $(PPUEXT),$(STATICLIBEXT),$(CLEANPPUFILES))))
|
||||
endif
|
||||
endif
|
||||
|
||||
@ -1276,9 +1276,9 @@ graph$(PPUEXT) : graph.pp strings$(PPUEXT) windows$(PPUEXT) $(SYSTEMPPU) \
|
||||
# Delphi Compatible Units
|
||||
#
|
||||
|
||||
sysutils$(PPUEXT) : $(OBJPASDIR)/sysutils.pp $(wildcard $(OBJPASDIR)/*.inc) \
|
||||
filutil.inc disk.inc objpas$(PPUEXT) dos$(PPUEXT) windows$(PPUEXT)
|
||||
$(COMPILER) -I$(OBJPASDIR) $(OBJPASDIR)/sysutils.pp $(REDIR)
|
||||
sysutils$(PPUEXT) : sysutils.pp $(wildcard $(OBJPASDIR)/*.inc) \
|
||||
objpas$(PPUEXT) dos$(PPUEXT) windows$(PPUEXT)
|
||||
$(COMPILER) -I$(OBJPASDIR) sysutils.pp $(REDIR)
|
||||
|
||||
typinfo$(PPUEXT): $(OBJPASDIR)/typinfo.pp objpas$(PPUEXT)
|
||||
$(COMPILER) -Sg $(OBJPASDIR)/typinfo.pp $(REDIR)
|
||||
|
||||
@ -150,9 +150,9 @@ graph$(PPUEXT) : graph.pp strings$(PPUEXT) windows$(PPUEXT) $(SYSTEMPPU) \
|
||||
# Delphi Compatible Units
|
||||
#
|
||||
|
||||
sysutils$(PPUEXT) : $(OBJPASDIR)/sysutils.pp $(wildcard $(OBJPASDIR)/*.inc) \
|
||||
filutil.inc disk.inc objpas$(PPUEXT) dos$(PPUEXT) windows$(PPUEXT)
|
||||
$(COMPILER) -I$(OBJPASDIR) $(OBJPASDIR)/sysutils.pp $(REDIR)
|
||||
sysutils$(PPUEXT) : sysutils.pp $(wildcard $(OBJPASDIR)/*.inc) \
|
||||
objpas$(PPUEXT) dos$(PPUEXT) windows$(PPUEXT)
|
||||
$(COMPILER) -I$(OBJPASDIR) sysutils.pp $(REDIR)
|
||||
|
||||
typinfo$(PPUEXT): $(OBJPASDIR)/typinfo.pp objpas$(PPUEXT)
|
||||
$(COMPILER) -Sg $(OBJPASDIR)/typinfo.pp $(REDIR)
|
||||
|
||||
@ -1,139 +0,0 @@
|
||||
{
|
||||
$Id$
|
||||
This file is part of the Free Pascal run time library.
|
||||
Copyright (c) 1999-2000 by the Free Pascal development team
|
||||
|
||||
Disk functions from Delphi's sysutils.pas
|
||||
|
||||
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.
|
||||
|
||||
**********************************************************************}
|
||||
|
||||
function GetDiskFreeSpace(drive:pchar;var sector_cluster,bytes_sector,
|
||||
freeclusters,totalclusters:longint):longbool;
|
||||
external 'kernel32' name 'GetDiskFreeSpaceA';
|
||||
type
|
||||
TGetDiskFreeSpaceEx = function(drive:pchar;var availableforcaller,
|
||||
total,free):longbool;stdcall;
|
||||
|
||||
var
|
||||
GetDiskFreeSpaceEx : TGetDiskFreeSpaceEx;
|
||||
|
||||
function diskfree(drive : byte) : int64;
|
||||
var
|
||||
disk : array[1..4] of char;
|
||||
secs,bytes,
|
||||
free,total : longint;
|
||||
qwtotal,qwfree,qwcaller : int64;
|
||||
|
||||
|
||||
begin
|
||||
if drive=0 then
|
||||
begin
|
||||
disk[1]:='\';
|
||||
disk[2]:=#0;
|
||||
end
|
||||
else
|
||||
begin
|
||||
disk[1]:=chr(drive+64);
|
||||
disk[2]:=':';
|
||||
disk[3]:='\';
|
||||
disk[4]:=#0;
|
||||
end;
|
||||
if assigned(GetDiskFreeSpaceEx) then
|
||||
begin
|
||||
if GetDiskFreeSpaceEx(@disk,qwcaller,qwtotal,qwfree) then
|
||||
diskfree:=qwfree
|
||||
else
|
||||
diskfree:=-1;
|
||||
end
|
||||
else
|
||||
begin
|
||||
if GetDiskFreeSpace(@disk,secs,bytes,free,total) then
|
||||
diskfree:=int64(free)*secs*bytes
|
||||
else
|
||||
diskfree:=-1;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
function disksize(drive : byte) : int64;
|
||||
var
|
||||
disk : array[1..4] of char;
|
||||
secs,bytes,
|
||||
free,total : longint;
|
||||
qwtotal,qwfree,qwcaller : int64;
|
||||
|
||||
begin
|
||||
if drive=0 then
|
||||
begin
|
||||
disk[1]:='\';
|
||||
disk[2]:=#0;
|
||||
end
|
||||
else
|
||||
begin
|
||||
disk[1]:=chr(drive+64);
|
||||
disk[2]:=':';
|
||||
disk[3]:='\';
|
||||
disk[4]:=#0;
|
||||
end;
|
||||
if assigned(GetDiskFreeSpaceEx) then
|
||||
begin
|
||||
if GetDiskFreeSpaceEx(@disk,qwcaller,qwtotal,qwfree) then
|
||||
disksize:=qwtotal
|
||||
else
|
||||
disksize:=-1;
|
||||
end
|
||||
else
|
||||
begin
|
||||
if GetDiskFreeSpace(@disk,secs,bytes,free,total) then
|
||||
disksize:=int64(total)*secs*bytes
|
||||
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;
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.2 2000-07-13 11:33:57 michael
|
||||
+ removed logs
|
||||
|
||||
}
|
||||
@ -1,9 +1,10 @@
|
||||
{
|
||||
$Id$
|
||||
This file is part of the Free Pascal run time library.
|
||||
Copyright (c) 1999-2000 by the Free Pascal development team
|
||||
Copyright (c) 1999-2000 by Florian Klaempfl
|
||||
member of the Free Pascal development team
|
||||
|
||||
File utility calls
|
||||
Sysutils unit for win32
|
||||
|
||||
See the file COPYING.FPC, included in this distribution,
|
||||
for details about the copyright.
|
||||
@ -13,10 +14,37 @@
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
|
||||
|
||||
**********************************************************************}
|
||||
unit sysutils;
|
||||
interface
|
||||
|
||||
{$MODE objfpc}
|
||||
{ force ansistrings }
|
||||
{$H+}
|
||||
|
||||
uses
|
||||
dos,windows;
|
||||
|
||||
|
||||
{ Include platform independent interface part }
|
||||
{$i sysutilh.inc}
|
||||
|
||||
{ platform dependent functions }
|
||||
|
||||
function SysErrorMessage(ErrorCode: Integer): String;
|
||||
|
||||
|
||||
|
||||
implementation
|
||||
|
||||
{ Include platform independent implementation part }
|
||||
{$i sysutils.inc}
|
||||
|
||||
|
||||
{****************************************************************************
|
||||
File Functions
|
||||
****************************************************************************}
|
||||
|
||||
Function FileOpen (Const FileName : string; Mode : Integer) : Longint;
|
||||
|
||||
const
|
||||
AccessMode: array[0..2] of Integer = (
|
||||
GENERIC_READ,
|
||||
@ -28,65 +56,61 @@ const
|
||||
FILE_SHARE_READ,
|
||||
FILE_SHARE_WRITE,
|
||||
FILE_SHARE_READ or FILE_SHARE_WRITE);
|
||||
|
||||
Var FN : string;
|
||||
|
||||
Var
|
||||
FN : string;
|
||||
begin
|
||||
FN:=FileName+#0;
|
||||
Result := CreateFile(@FN[1], AccessMode[Mode and 3],
|
||||
ShareMode[(Mode and $F0) shr 4], nil, OPEN_EXISTING,
|
||||
result := CreateFile(@FN[1], AccessMode[Mode and 3],
|
||||
ShareMode[(Mode and $F0) shr 4], nil, OPEN_EXISTING,
|
||||
FILE_ATTRIBUTE_NORMAL, 0);
|
||||
end;
|
||||
|
||||
|
||||
Function FileCreate (Const FileName : String) : Longint;
|
||||
|
||||
Var FN : string;
|
||||
|
||||
Var
|
||||
FN : string;
|
||||
begin
|
||||
FN:=FileName+#0;
|
||||
Result := CreateFile(@FN[1], GENERIC_READ or GENERIC_WRITE,
|
||||
0, nil, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0);
|
||||
Result := CreateFile(@FN[1], GENERIC_READ or GENERIC_WRITE,
|
||||
0, nil, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0);
|
||||
end;
|
||||
|
||||
|
||||
Function FileRead (Handle : Longint; Var Buffer; Count : longint) : Longint;
|
||||
|
||||
Var res : Longint;
|
||||
|
||||
Var
|
||||
res : Longint;
|
||||
begin
|
||||
if not ReadFile(Handle, Buffer, Count, res, nil) then res := -1;
|
||||
if not ReadFile(Handle, Buffer, Count, res, nil) then
|
||||
res := -1;
|
||||
FileRead:=Res;
|
||||
end;
|
||||
|
||||
|
||||
Function FileWrite (Handle : Longint; const Buffer; Count : Longint) : Longint;
|
||||
|
||||
Var Res : longint;
|
||||
|
||||
Var
|
||||
Res : longint;
|
||||
begin
|
||||
if not WriteFile(Handle, Buffer, Count, Res, nil) then Res:= -1;
|
||||
if not WriteFile(Handle, Buffer, Count, Res, nil) then
|
||||
Res:= -1;
|
||||
FileWrite:=Res;
|
||||
end;
|
||||
|
||||
|
||||
Function FileSeek (Handle,FOffset,Origin : Longint) : Longint;
|
||||
|
||||
begin
|
||||
Result := SetFilePointer(Handle, FOffset, nil, Origin);
|
||||
end;
|
||||
|
||||
|
||||
Procedure FileClose (Handle : Longint);
|
||||
|
||||
begin
|
||||
if Handle<=4 then
|
||||
exit;
|
||||
CloseHandle(Handle);
|
||||
end;
|
||||
|
||||
Function FileTruncate (Handle,Size: Longint) : boolean;
|
||||
|
||||
Function FileTruncate (Handle,Size: Longint) : boolean;
|
||||
begin
|
||||
Result:=SetFilePointer(handle,Size,nil,FILE_BEGIN)<>-1;
|
||||
If Result then
|
||||
@ -112,25 +136,23 @@ end;
|
||||
|
||||
|
||||
Function FileAge (Const FileName : String): Longint;
|
||||
|
||||
var
|
||||
Handle: THandle;
|
||||
FindData: TWin32FindData;
|
||||
|
||||
begin
|
||||
Handle := FindFirstFile(Pchar(FileName), @FindData);
|
||||
if Handle <> INVALID_HANDLE_VALUE then
|
||||
begin
|
||||
Windows.FindClose(Handle);
|
||||
if (FindData.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) = 0 then
|
||||
If WinToDosTime(FindData.ftLastWriteTime,Result) then exit;
|
||||
Windows.FindClose(Handle);
|
||||
if (FindData.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) = 0 then
|
||||
If WinToDosTime(FindData.ftLastWriteTime,Result) then
|
||||
exit;
|
||||
end;
|
||||
Result := -1;
|
||||
end;
|
||||
|
||||
|
||||
Function FileExists (Const FileName : String) : Boolean;
|
||||
|
||||
var
|
||||
Handle: THandle;
|
||||
FindData: TWin32FindData;
|
||||
@ -141,16 +163,16 @@ begin
|
||||
Windows.FindClose(Handle);
|
||||
end;
|
||||
|
||||
Function FindMatch(var f: TSearchRec) : Longint;
|
||||
|
||||
Function FindMatch(var f: TSearchRec) : Longint;
|
||||
begin
|
||||
{ Find file with correct attribute }
|
||||
While (F.FindData.dwFileAttributes and F.ExcludeAttr)<>0 do
|
||||
begin
|
||||
if not FindNextFile (F.FindHandle,@F.FindData) then
|
||||
begin
|
||||
Result:=GetLastError;
|
||||
exit;
|
||||
Result:=GetLastError;
|
||||
exit;
|
||||
end;
|
||||
end;
|
||||
{ Convert some attributes back }
|
||||
@ -161,8 +183,8 @@ begin
|
||||
Result:=0;
|
||||
end;
|
||||
|
||||
Function FindFirst (Const Path : String; Attr : Longint; Var Rslt : TSearchRec) : Longint;
|
||||
|
||||
Function FindFirst (Const Path : String; Attr : Longint; Var Rslt : TSearchRec) : Longint;
|
||||
begin
|
||||
Rslt.Name:=Path;
|
||||
Rslt.Attr:=attr;
|
||||
@ -171,17 +193,16 @@ begin
|
||||
{ FindFirstFile is a Win32 Call }
|
||||
Rslt.FindHandle:=FindFirstFile (PChar(Path),@Rslt.FindData);
|
||||
If Rslt.FindHandle=Invalid_Handle_value then
|
||||
begin
|
||||
begin
|
||||
Result:=GetLastError;
|
||||
exit;
|
||||
end;
|
||||
end;
|
||||
{ Find file with correct attribute }
|
||||
Result:=FindMatch(Rslt);
|
||||
end;
|
||||
|
||||
|
||||
Function FindNext (Var Rslt : TSearchRec) : Longint;
|
||||
|
||||
begin
|
||||
if FindNextFile(Rslt.FindHandle, @Rslt.FindData) then
|
||||
Result := FindMatch(Rslt)
|
||||
@ -191,46 +212,42 @@ end;
|
||||
|
||||
|
||||
Procedure FindClose (Var F : TSearchrec);
|
||||
|
||||
begin
|
||||
if F.FindHandle <> INVALID_HANDLE_VALUE then
|
||||
Windows.FindClose(F.FindHandle);
|
||||
end;
|
||||
|
||||
|
||||
|
||||
Function FileGetDate (Handle : Longint) : Longint;
|
||||
|
||||
Var FT : TFileTime;
|
||||
|
||||
Var
|
||||
FT : TFileTime;
|
||||
begin
|
||||
If GetFileTime(Handle,nil,nil,@ft) and
|
||||
WinToDosTime(FT,Result) then exit;
|
||||
WinToDosTime(FT,Result) then
|
||||
exit;
|
||||
Result:=-1;
|
||||
end;
|
||||
|
||||
|
||||
Function FileSetDate (Handle,Age : Longint) : Longint;
|
||||
|
||||
Var FT: TFileTime;
|
||||
|
||||
Var
|
||||
FT: TFileTime;
|
||||
begin
|
||||
Result := 0;
|
||||
if DosToWinTime(Age,FT) and
|
||||
SetFileTime(Handle, ft, ft, FT) then Exit;
|
||||
SetFileTime(Handle, ft, ft, FT) then
|
||||
Exit;
|
||||
Result := GetLastError;
|
||||
end;
|
||||
|
||||
|
||||
Function FileGetAttr (Const FileName : String) : Longint;
|
||||
|
||||
begin
|
||||
Result:=GetFileAttributes(PChar(FileName));
|
||||
end;
|
||||
|
||||
|
||||
Function FileSetAttr (Const Filename : String; Attr: longint) : Longint;
|
||||
|
||||
begin
|
||||
if not SetFileAttributes(PChar(FileName), Attr) then
|
||||
Result := GetLastError
|
||||
@ -240,24 +257,21 @@ end;
|
||||
|
||||
|
||||
Function DeleteFile (Const FileName : String) : Boolean;
|
||||
|
||||
begin
|
||||
DeleteFile:=Windows.DeleteFile(Pchar(FileName));
|
||||
end;
|
||||
|
||||
|
||||
Function RenameFile (Const OldName, NewName : String) : Boolean;
|
||||
|
||||
begin
|
||||
Result := MoveFile(PChar(OldName), PChar(NewName));
|
||||
end;
|
||||
|
||||
|
||||
Function FileSearch (Const Name, DirList : String) : String;
|
||||
|
||||
Var I : longint;
|
||||
Temp : String;
|
||||
|
||||
Var
|
||||
I : longint;
|
||||
Temp : String;
|
||||
begin
|
||||
Result:='';
|
||||
temp:=Dirlist;
|
||||
@ -265,13 +279,13 @@ begin
|
||||
I:=pos(';',Temp);
|
||||
If I<>0 then
|
||||
begin
|
||||
Result:=Copy (Temp,1,i-1);
|
||||
system.Delete(Temp,1,I);
|
||||
Result:=Copy (Temp,1,i-1);
|
||||
system.Delete(Temp,1,I);
|
||||
end
|
||||
else
|
||||
begin
|
||||
Result:=Temp;
|
||||
Temp:='';
|
||||
Result:=Temp;
|
||||
Temp:='';
|
||||
end;
|
||||
If result[length(result)]<>'\' then
|
||||
Result:=Result+'\';
|
||||
@ -281,49 +295,188 @@ begin
|
||||
until (length(temp)=0) or (length(result)<>0);
|
||||
end;
|
||||
|
||||
Procedure GetLocalTime(var ST: TSystemTime);
|
||||
|
||||
Var Syst:Systemtime;
|
||||
{****************************************************************************
|
||||
Disk Functions
|
||||
****************************************************************************}
|
||||
|
||||
function GetDiskFreeSpace(drive:pchar;var sector_cluster,bytes_sector,
|
||||
freeclusters,totalclusters:longint):longbool;
|
||||
external 'kernel32' name 'GetDiskFreeSpaceA';
|
||||
type
|
||||
TGetDiskFreeSpaceEx = function(drive:pchar;var availableforcaller,total,free):longbool;stdcall;
|
||||
|
||||
var
|
||||
GetDiskFreeSpaceEx : TGetDiskFreeSpaceEx;
|
||||
|
||||
function diskfree(drive : byte) : int64;
|
||||
var
|
||||
disk : array[1..4] of char;
|
||||
secs,bytes,
|
||||
free,total : longint;
|
||||
qwtotal,qwfree,qwcaller : int64;
|
||||
|
||||
|
||||
begin
|
||||
if drive=0 then
|
||||
begin
|
||||
disk[1]:='\';
|
||||
disk[2]:=#0;
|
||||
end
|
||||
else
|
||||
begin
|
||||
disk[1]:=chr(drive+64);
|
||||
disk[2]:=':';
|
||||
disk[3]:='\';
|
||||
disk[4]:=#0;
|
||||
end;
|
||||
if assigned(GetDiskFreeSpaceEx) then
|
||||
begin
|
||||
if GetDiskFreeSpaceEx(@disk,qwcaller,qwtotal,qwfree) then
|
||||
diskfree:=qwfree
|
||||
else
|
||||
diskfree:=-1;
|
||||
end
|
||||
else
|
||||
begin
|
||||
if GetDiskFreeSpace(@disk,secs,bytes,free,total) then
|
||||
diskfree:=int64(free)*secs*bytes
|
||||
else
|
||||
diskfree:=-1;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
function disksize(drive : byte) : int64;
|
||||
var
|
||||
disk : array[1..4] of char;
|
||||
secs,bytes,
|
||||
free,total : longint;
|
||||
qwtotal,qwfree,qwcaller : int64;
|
||||
begin
|
||||
if drive=0 then
|
||||
begin
|
||||
disk[1]:='\';
|
||||
disk[2]:=#0;
|
||||
end
|
||||
else
|
||||
begin
|
||||
disk[1]:=chr(drive+64);
|
||||
disk[2]:=':';
|
||||
disk[3]:='\';
|
||||
disk[4]:=#0;
|
||||
end;
|
||||
if assigned(GetDiskFreeSpaceEx) then
|
||||
begin
|
||||
if GetDiskFreeSpaceEx(@disk,qwcaller,qwtotal,qwfree) then
|
||||
disksize:=qwtotal
|
||||
else
|
||||
disksize:=-1;
|
||||
end
|
||||
else
|
||||
begin
|
||||
if GetDiskFreeSpace(@disk,secs,bytes,free,total) then
|
||||
disksize:=int64(total)*secs*bytes
|
||||
else
|
||||
disksize:=-1;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
Function GetCurrentDir : String;
|
||||
begin
|
||||
GetDir(0, result);
|
||||
end;
|
||||
|
||||
|
||||
Function SetCurrentDir (Const NewDir : String) : Boolean;
|
||||
begin
|
||||
{$I-}
|
||||
ChDir(NewDir);
|
||||
{$I+}
|
||||
result := (IOResult = 0);
|
||||
end;
|
||||
|
||||
|
||||
Function CreateDir (Const NewDir : String) : Boolean;
|
||||
begin
|
||||
{$I-}
|
||||
MkDir(NewDir);
|
||||
{$I+}
|
||||
result := (IOResult = 0);
|
||||
end;
|
||||
|
||||
|
||||
Function RemoveDir (Const Dir : String) : Boolean;
|
||||
begin
|
||||
{$I-}
|
||||
RmDir(Dir);
|
||||
{$I+}
|
||||
result := (IOResult = 0);
|
||||
end;
|
||||
|
||||
|
||||
{****************************************************************************
|
||||
Time Functions
|
||||
****************************************************************************}
|
||||
|
||||
|
||||
Procedure GetLocalTime(var SystemTime: TSystemTime);
|
||||
Var
|
||||
Syst : Windows.TSystemtime;
|
||||
begin
|
||||
windows.Getlocaltime(@syst);
|
||||
st.year:=syst.wYear;
|
||||
st.month:=syst.wMonth;
|
||||
st.day:=syst.wDay;
|
||||
st.hour:=syst.wHour;
|
||||
st.minute:=syst.wMinute;
|
||||
st.second:=syst.wSecond;
|
||||
st.millisecond:=syst.wMilliSeconds;
|
||||
SystemTime.year:=syst.wYear;
|
||||
SystemTime.month:=syst.wMonth;
|
||||
SystemTime.day:=syst.wDay;
|
||||
SystemTime.hour:=syst.wHour;
|
||||
SystemTime.minute:=syst.wMinute;
|
||||
SystemTime.second:=syst.wSecond;
|
||||
SystemTime.millisecond:=syst.wMilliSeconds;
|
||||
end;
|
||||
Procedure InitAnsi;
|
||||
|
||||
Var i : longint;
|
||||
|
||||
{****************************************************************************
|
||||
Misc Functions
|
||||
****************************************************************************}
|
||||
|
||||
procedure Beep;
|
||||
begin
|
||||
{ Fill table entries 0 to 127 }
|
||||
for i := 0 to 96 do
|
||||
UpperCaseTable[i] := chr(i);
|
||||
for i := 97 to 122 do
|
||||
UpperCaseTable[i] := chr(i - 32);
|
||||
for i := 123 to 191 do
|
||||
UpperCaseTable[i] := chr(i);
|
||||
Move (CPISO88591UCT,UpperCaseTable[192],SizeOf(CPISO88591UCT));
|
||||
|
||||
for i := 0 to 64 do
|
||||
LowerCaseTable[i] := chr(i);
|
||||
for i := 65 to 90 do
|
||||
LowerCaseTable[i] := chr(i + 32);
|
||||
for i := 91 to 191 do
|
||||
LowerCaseTable[i] := chr(i);
|
||||
Move (CPISO88591LCT,UpperCaseTable[192],SizeOf(CPISO88591UCT));
|
||||
MessageBeep(0);
|
||||
end;
|
||||
|
||||
|
||||
{****************************************************************************
|
||||
Locale Functions
|
||||
****************************************************************************}
|
||||
|
||||
Procedure InitAnsi;
|
||||
Var
|
||||
i : longint;
|
||||
begin
|
||||
{ Fill table entries 0 to 127 }
|
||||
for i := 0 to 96 do
|
||||
UpperCaseTable[i] := chr(i);
|
||||
for i := 97 to 122 do
|
||||
UpperCaseTable[i] := chr(i - 32);
|
||||
for i := 123 to 191 do
|
||||
UpperCaseTable[i] := chr(i);
|
||||
Move (CPISO88591UCT,UpperCaseTable[192],SizeOf(CPISO88591UCT));
|
||||
|
||||
for i := 0 to 64 do
|
||||
LowerCaseTable[i] := chr(i);
|
||||
for i := 65 to 90 do
|
||||
LowerCaseTable[i] := chr(i + 32);
|
||||
for i := 91 to 191 do
|
||||
LowerCaseTable[i] := chr(i);
|
||||
Move (CPISO88591LCT,UpperCaseTable[192],SizeOf(CPISO88591UCT));
|
||||
end;
|
||||
|
||||
|
||||
function GetLocaleStr(LID, LT: Longint; const Def: string): ShortString;
|
||||
|
||||
var
|
||||
L: Integer;
|
||||
Buf: array[0..255] of Char;
|
||||
|
||||
begin
|
||||
L := GetLocaleInfo(LID, LT, Buf, SizeOf(Buf));
|
||||
if L > 0 then
|
||||
@ -332,8 +485,8 @@ begin
|
||||
Result := Def;
|
||||
end;
|
||||
|
||||
function GetLocaleChar(LID, LT: Longint; Def: Char): Char;
|
||||
|
||||
function GetLocaleChar(LID, LT: Longint; Def: Char): Char;
|
||||
var
|
||||
Buf: array[0..1] of Char;
|
||||
begin
|
||||
@ -342,12 +495,12 @@ begin
|
||||
else
|
||||
Result := Def;
|
||||
end;
|
||||
Function GetLocaleInt(LID,TP,Def: LongInt): LongInt;
|
||||
|
||||
|
||||
Function GetLocaleInt(LID,TP,Def: LongInt): LongInt;
|
||||
Var
|
||||
S: String;
|
||||
C: Integer;
|
||||
|
||||
Begin
|
||||
S:=GetLocaleStr(LID,TP,'0');
|
||||
Val(S,Result,C);
|
||||
@ -355,13 +508,12 @@ Begin
|
||||
Result:=Def;
|
||||
End;
|
||||
|
||||
procedure GetFormatSettings;
|
||||
|
||||
procedure GetFormatSettings;
|
||||
var
|
||||
HF : Shortstring;
|
||||
LID : LCID;
|
||||
I,Day,DateOrder : longint;
|
||||
|
||||
begin
|
||||
LID := GetThreadLocale;
|
||||
{ Date stuff }
|
||||
@ -413,21 +565,60 @@ begin
|
||||
CurrencyDecimals:=StrToIntDef(GetLocaleStr(LID, LOCALE_ICURRDIGITS, '0'), 0);
|
||||
end;
|
||||
|
||||
|
||||
Procedure InitInternational;
|
||||
|
||||
{
|
||||
called by sysutils initialization routines to set up
|
||||
internationalization support.
|
||||
}
|
||||
|
||||
begin
|
||||
InitAnsi;
|
||||
GetFormatSettings;
|
||||
InitAnsi;
|
||||
GetFormatSettings;
|
||||
end;
|
||||
|
||||
|
||||
{****************************************************************************
|
||||
Target Dependent
|
||||
****************************************************************************}
|
||||
|
||||
function FormatMessageA(dwFlags : DWORD;
|
||||
lpSource : Pointer;
|
||||
dwMessageId : DWORD;
|
||||
dwLanguageId: DWORD;
|
||||
lpBuffer : PCHAR;
|
||||
nSize : DWORD;
|
||||
Arguments : Pointer): DWORD; external 'kernel32' name 'FormatMessageA';
|
||||
|
||||
function SysErrorMessage(ErrorCode: Integer): String;
|
||||
const
|
||||
MaxMsgSize = Format_Message_Max_Width_Mask;
|
||||
var
|
||||
MsgBuffer: pChar;
|
||||
begin
|
||||
GetMem(MsgBuffer, MaxMsgSize);
|
||||
FillChar(MsgBuffer^, MaxMsgSize, #0);
|
||||
FormatMessageA(FORMAT_MESSAGE_FROM_SYSTEM,
|
||||
nil,
|
||||
ErrorCode,
|
||||
MakeLangId(LANG_NEUTRAL, SUBLANG_DEFAULT),
|
||||
MsgBuffer, { This function allocs the memory }
|
||||
MaxMsgSize, { Maximum message size }
|
||||
nil);
|
||||
SysErrorMessage := StrPas(MsgBuffer);
|
||||
FreeMem(MsgBuffer, MaxMsgSize);
|
||||
end;
|
||||
|
||||
|
||||
{****************************************************************************
|
||||
Initialization code
|
||||
****************************************************************************}
|
||||
|
||||
Initialization
|
||||
InitExceptions; { Initialize exceptions. OS independent }
|
||||
InitInternational; { Initialize internationalization settings }
|
||||
Finalization
|
||||
OutOfMemory.Free;
|
||||
InValidPointer.Free;
|
||||
end.
|
||||
{
|
||||
$Log$
|
||||
Revision 1.2 2000-07-13 11:33:57 michael
|
||||
+ removed logs
|
||||
|
||||
Revision 1.2 2000-08-20 15:46:46 peter
|
||||
* sysutils.pp moved to target and merged with disk.inc, filutil.inc
|
||||
|
||||
}
|
||||
Loading…
Reference in New Issue
Block a user