mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-06-02 02:42:40 +02:00
1dfa5c2e74
this allows passing command lines longer than 126 chars to
Free Pascal or go32v2 programs.
By default only command lines longer than 126 chars are
passed using !proxy method,
it is however possible to disable this conversion completely by
set Use_go32v2_proxy boolean variable to false (true by fdefault).
In that case, command lines longer than 126 will be truncated, but
a warning is echoed to stderr.
For testing purposes, it is possible to set the boolean variable
force_go32v2_proxy to true to force systematic use of this
conversion.
This is set by default if the RTL is compiled with
SYSTEM_DEBUG_STARTUP conditional set.
To allow use by sysutils unit, a new procedure:
exec_ansistring(path : string;comline : ansistring);
has been added to the interface, which is now called instead
of Dos.Exec from Sysutils.ExecuteProcess
git-svn-id: trunk@18159 -
858 lines
20 KiB
ObjectPascal
858 lines
20 KiB
ObjectPascal
{
|
|
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.
|
|
|
|
**********************************************************************}
|
|
|
|
{$inline on}
|
|
|
|
unit sysutils;
|
|
interface
|
|
|
|
{$MODE objfpc}
|
|
{$MODESWITCH out}
|
|
{ force ansistrings }
|
|
{$H+}
|
|
|
|
uses
|
|
go32,dos;
|
|
|
|
{$DEFINE HAS_SLEEP}
|
|
{ Include platform independent interface part }
|
|
{$i sysutilh.inc}
|
|
|
|
|
|
implementation
|
|
|
|
uses
|
|
sysconst;
|
|
|
|
{$DEFINE FPC_FEXPAND_UNC} (* UNC paths are supported *)
|
|
{$DEFINE FPC_FEXPAND_DRIVES} (* Full paths begin with drive specification *)
|
|
|
|
{ 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 := UnusedHandle;
|
|
StringToTB(FileName);
|
|
if LFNSupport then
|
|
begin
|
|
Regs.Eax := $716c; { Use LFN Open/Create API }
|
|
Regs.Edx := Action; { Action if file does/doesn't exist }
|
|
Regs.Esi := tb_offset;
|
|
Regs.Ebx := $2000 + (Mode and $ff); { File open mode }
|
|
end
|
|
else
|
|
begin
|
|
if (Action and $00f0) <> 0 then
|
|
Regs.Eax := $3c00 { Map to Create/Replace API }
|
|
else
|
|
Regs.Eax := $3d00 + (Mode and $ff); { Map to Open_Existing API }
|
|
Regs.Edx := tb_offset;
|
|
end;
|
|
Regs.Ds := tb_segment;
|
|
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 FileCreate (Const FileName : String; ShareMode:longint; Rights : longint) : Longint;
|
|
begin
|
|
FileCreate:=FileCreate(FileName);
|
|
end;
|
|
|
|
|
|
Function FileCreate (Const FileName : String; Rights:longint) : Longint;
|
|
begin
|
|
FileCreate:=FileCreate(FileName);
|
|
end;
|
|
|
|
|
|
Function FileRead (Handle : Longint; Out Buffer; Count : longint) : Longint;
|
|
var
|
|
regs : registers;
|
|
size,
|
|
readsize : longint;
|
|
begin
|
|
readsize:=0;
|
|
while Count > 0 do
|
|
begin
|
|
if Count>tb_size then
|
|
size:=tb_size
|
|
else
|
|
size:=Count;
|
|
regs.realecx:=size;
|
|
regs.realedx:=tb_offset;
|
|
regs.realds:=tb_segment;
|
|
regs.realebx:=Handle;
|
|
regs.realeax:=$3f00;
|
|
RealIntr($21,regs);
|
|
if (regs.realflags and carryflag) <> 0 then
|
|
begin
|
|
Result:=-1;
|
|
exit;
|
|
end;
|
|
syscopyfromdos(Longint(@Buffer)+readsize,lo(regs.realeax));
|
|
inc(readsize,lo(regs.realeax));
|
|
dec(Count,lo(regs.realeax));
|
|
{ stop when not the specified size is read }
|
|
if lo(regs.realeax)<size then
|
|
break;
|
|
end;
|
|
Result:=readsize;
|
|
end;
|
|
|
|
|
|
Function FileWrite (Handle : Longint; const Buffer; Count : Longint) : Longint;
|
|
var
|
|
regs : registers;
|
|
size,
|
|
writesize : longint;
|
|
begin
|
|
writesize:=0;
|
|
while Count > 0 do
|
|
begin
|
|
if Count>tb_size then
|
|
size:=tb_size
|
|
else
|
|
size:=Count;
|
|
syscopytodos(Longint(@Buffer)+writesize,size);
|
|
regs.realecx:=size;
|
|
regs.realedx:=tb_offset;
|
|
regs.realds:=tb_segment;
|
|
regs.realebx:=Handle;
|
|
regs.realeax:=$4000;
|
|
RealIntr($21,regs);
|
|
if (regs.realflags and carryflag) <> 0 then
|
|
begin
|
|
Result:=-1;
|
|
exit;
|
|
end;
|
|
inc(writesize,lo(regs.realeax));
|
|
dec(Count,lo(regs.realeax));
|
|
{ stop when not the specified size is written }
|
|
if lo(regs.realeax)<size then
|
|
break;
|
|
end;
|
|
Result:=WriteSize;
|
|
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;
|
|
|
|
|
|
Function FileSeek (Handle : Longint; FOffset: Int64; Origin: Integer) : Int64;
|
|
begin
|
|
{$warning need to add 64bit call }
|
|
FileSeek:=FileSeek(Handle,Longint(FOffset),Longint(Origin));
|
|
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: THandle; Size: Int64) : boolean;
|
|
var
|
|
regs : trealregs;
|
|
begin
|
|
if Size > high (longint) then
|
|
FileTruncate := false
|
|
else
|
|
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;
|
|
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
|
|
Sr : Searchrec;
|
|
begin
|
|
DOS.FindFirst(FileName,$3f,sr);
|
|
if DosError = 0 then
|
|
begin
|
|
{ No volumeid,directory }
|
|
Result:=(sr.attr and $18)=0;
|
|
Dos.FindClose(sr);
|
|
end
|
|
else
|
|
Result:=false;
|
|
end;
|
|
|
|
|
|
Function DirectoryExists (Const Directory : String) : Boolean;
|
|
Var
|
|
Sr : Searchrec;
|
|
begin
|
|
DOS.FindFirst(Directory,$3f,sr);
|
|
if DosError = 0 then
|
|
begin
|
|
Result:=(sr.attr and $10)=$10;
|
|
Dos.FindClose(sr);
|
|
end
|
|
else
|
|
Result:=false;
|
|
end;
|
|
|
|
|
|
Function FindFirst (Const Path : String; Attr : Longint; out 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;
|
|
|
|
|
|
{****************************************************************************
|
|
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;
|
|
|
|
procedure OldDosDiskData;
|
|
begin
|
|
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;
|
|
|
|
BEGIN
|
|
if LFNSupport then
|
|
begin
|
|
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;
|
|
Rec.RetSize := 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.flags and fcarry) = 0 then {No error clausule in int except cf}
|
|
begin
|
|
copyfromdos(rec,Sizeof(ExtendedFat32FreeSpaceRec));
|
|
if Rec.RetSize = 0 then (* Error - "FAT32" function not supported! *)
|
|
OldDosDiskData
|
|
else
|
|
if Free then
|
|
Do_DiskData:=int64(rec.AvailAllocUnits)*rec.SecPerClus*rec.BytePerSec
|
|
else
|
|
Do_DiskData:=int64(rec.TotalAllocUnits)*rec.SecPerClus*rec.BytePerSec;
|
|
end
|
|
else
|
|
OldDosDiskData;
|
|
end
|
|
else
|
|
OldDosDiskData;
|
|
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*10;
|
|
Regs.ah := $2A;
|
|
RealIntr($21, Regs);
|
|
SystemTime.Year := Regs.Cx;
|
|
SystemTime.Month := Regs.Dh;
|
|
SystemTime.Day := Regs.Dl;
|
|
end ;
|
|
|
|
|
|
{****************************************************************************
|
|
Misc Functions
|
|
****************************************************************************}
|
|
|
|
procedure sysBeep;
|
|
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
|
|
InitInternationalGeneric;
|
|
InitAnsi;
|
|
end;
|
|
|
|
function SysErrorMessage(ErrorCode: Integer): String;
|
|
|
|
begin
|
|
Result:=Format(SUnknownErrorCode,[ErrorCode]);
|
|
end;
|
|
|
|
{****************************************************************************
|
|
Os utils
|
|
****************************************************************************}
|
|
|
|
Function GetEnvironmentVariable(Const EnvVar : String) : String;
|
|
|
|
begin
|
|
Result:=FPCGetEnvVarFromP(envp,EnvVar);
|
|
end;
|
|
|
|
Function GetEnvironmentVariableCount : Integer;
|
|
|
|
begin
|
|
Result:=FPCCountEnvVar(EnvP);
|
|
end;
|
|
|
|
Function GetEnvironmentString(Index : Integer) : String;
|
|
|
|
begin
|
|
Result:=FPCGetEnvStrFromP(Envp,Index);
|
|
end;
|
|
|
|
|
|
function ExecuteProcess(Const Path: AnsiString; Const ComLine: AnsiString;Flags:TExecuteFlags=[]):integer;
|
|
var
|
|
e : EOSError;
|
|
CommandLine: AnsiString;
|
|
|
|
begin
|
|
dos.exec_ansistring(path,comline);
|
|
|
|
if (Dos.DosError <> 0) then
|
|
begin
|
|
if ComLine <> '' then
|
|
CommandLine := Path + ' ' + ComLine
|
|
else
|
|
CommandLine := Path;
|
|
e:=EOSError.CreateFmt(SExecuteProcessFailed,[CommandLine,Dos.DosError]);
|
|
e.ErrorCode:=Dos.DosError;
|
|
raise e;
|
|
end;
|
|
Result := DosExitCode;
|
|
end;
|
|
|
|
|
|
function ExecuteProcess (const Path: AnsiString;
|
|
const ComLine: array of AnsiString;Flags:TExecuteFlags=[]): integer;
|
|
|
|
var
|
|
CommandLine: AnsiString;
|
|
I: integer;
|
|
|
|
begin
|
|
Commandline := '';
|
|
for I := 0 to High (ComLine) do
|
|
if Pos (' ', ComLine [I]) <> 0 then
|
|
CommandLine := CommandLine + ' ' + '"' + ComLine [I] + '"'
|
|
else
|
|
CommandLine := CommandLine + ' ' + Comline [I];
|
|
ExecuteProcess := ExecuteProcess (Path, CommandLine);
|
|
end;
|
|
|
|
|
|
{*************************************************************************
|
|
Sleep
|
|
*************************************************************************}
|
|
|
|
procedure Sleep (MilliSeconds: Cardinal);
|
|
var
|
|
R: Registers;
|
|
T0, T1, T2: int64;
|
|
DayOver: boolean;
|
|
begin
|
|
(* Sleep is supposed to give up time slice - DOS Idle Interrupt chosen
|
|
because it should be supported in all DOS versions. Not precise at all,
|
|
though - the smallest step is 10 ms even in the best case. *)
|
|
R.AH := $2C;
|
|
RealIntr($21, R);
|
|
T0 := R.CH * 3600000 + R.CL * 60000 + R.DH * 1000 + R.DL * 10;
|
|
T2 := T0 + MilliSeconds;
|
|
DayOver := T2 > (24 * 3600000);
|
|
repeat
|
|
Intr ($28, R);
|
|
(* R.AH := $2C; - should be preserved. *)
|
|
RealIntr($21, R);
|
|
T1 := R.CH * 3600000 + R.CL * 60000 + R.DH * 1000 + R.DL * 10;
|
|
if DayOver and (T1 < T0) then
|
|
Inc (T1, 24 * 3600000);
|
|
until T1 >= T2;
|
|
end;
|
|
|
|
{****************************************************************************
|
|
Initialization code
|
|
****************************************************************************}
|
|
|
|
Initialization
|
|
InitExceptions; { Initialize exceptions. OS independent }
|
|
InitInternational; { Initialize internationalization settings }
|
|
OnBeep:=@SysBeep;
|
|
Finalization
|
|
DoneExceptions;
|
|
end.
|