OS/2 Shareware BBS: 10 Tools/10-Tools.zip/vp21beta.zip/ARTLSRC.RAR/VPSYSW32.PAS

Pascal/Delphi Source File | 2000-08-16 | 60KB | 2,218 lines

//█▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀█
//█                                                       █
//█      Virtual Pascal Runtime Library.  Version 2.1.    █
//█      System interface layer Win32                     █
//█      ─────────────────────────────────────────────────█
//█      Copyright (C) 1995-2000 vpascal.com              █
//█                                                       █
//▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀

var
  SysBufInfo: TConsoleScreenBufferInfo;
  SysScrBuf: array[0..16*1024-1] of Char;

type
  TSysMouQUeue = array[0..15] of TSysMouseEvent;
  PSysMouQueue = ^TSysMouQueue;
  TSysKeyQueue = array[0..15] of TSysKeyEvent;
  PSysKeyQueue = ^tSysKeyQueue;

const
  // Pointers to keyboard interface variables located either in the
  // VpKbdW32 unit, or in the VpKbdW32.Dll file, if available
  pSysKeyCount   : pLongint     = nil;
  pSysMouCount   : pLongint     = nil;
  pSysKeyQue     : pSysKeyQueue = nil;
  pSysMouQue     : pSysMouQueue = nil;
  pSysShiftState : pByte        = nil;

  SysConIn:    Longint = -1;
  SysConOut:   Longint = -1;
  tidCursor:   Longint = -1;  // Thread ID of cursor thread
  semCursor:   Longint = -1;  // Event semaphore, set when cursor pos changes
  CurXPos:     Longint = -1;  // Internally maintained cursor position
  CurYPos:     Longint = -1;
  SysPlatform: Longint = -1;  // Platform ID, from SysPlatformID

type
  PStandardCell = ^TStandardCell;
  TStandardCell = packed record
    Ch   : Char;
    Attr : Byte;
  end;

  TKbdInit = procedure(var _pSysKeyCount, _pSysKeyQue, _pSysShiftState, _pSysMouCount, _pSysMouQue);
  TKbdUpdateEventQueues = procedure;

const
  KbdDllName     = 'VpKbdW32.Dll'; // Name of keyboard handler DLL
  hKbdDll        : Longint = -1;   // Handle of keyboard DLL
  name_KbdInit             = 'KbdInit';
  name_KbdUpdateEventQueue = 'KbdUpdateEventQueues';

  pKbdInit : TKbdInit = nil;
  pKbdUpdateEventQueues : TKbdUpdateEventQueues = nil;

function QueryProcAddr(Name: PChar; IsKernel: Boolean): Pointer;
const
  Names: array[Boolean] of PChar = ('user32.dll', 'kernel32.dll');
  Handles: array[Boolean] of THandle = (0, 0);
var
  K: Boolean;
begin
  K := IsKernel;
  if Handles[K] = 0 then
    Handles[K] := LoadLibrary(Names[K]);
  Result := GetProcAddress(Handles[K], Name);
end;

const
  AccessMode: array[0..2] of Integer = (
    generic_Read, generic_Write, generic_Read or generic_Write);
  ShareMode: array[0..4] of Integer = (
    0, 0, file_share_Read, file_share_Write, file_share_Read or file_share_Write);

function SetResult(Success: Boolean): Longint;
begin
  Result := 0;
  if not Success then
    Result := GetLastError;
end;

function SysFileStdIn: Longint;
begin
  Result := GetStdHandle(std_Input_Handle);
end;

function SysFileStdOut: Longint;
begin
  Result := GetStdHandle(std_Output_Handle);
end;

function SysFileStdErr: Longint;
begin
  Result := GetStdHandle(std_Error_Handle);
end;

threadvar
  SysAnsiFn: Array[0..260] of char;
  SysOemFn: Array[0..260] of char;

function AnsiFn(_FileName: PChar): PChar;
begin
  // Convert filename to ANSI character set
  OemToChar(_FileName, SysAnsiFn);
  Result := SysAnsiFn;
end;

function OemFn(_FileName: PChar): PChar;
begin
  // Convert filename to OEM character set
  CharToOem(_FileName, SysOemFn);
  Result := SysOemFn;
end;

function SysFileOpen_Create(Open: Boolean;FileName: PChar; Mode,Attr,Action: Longint; var Handle: Longint): Longint;
var
  SA: TSecurityAttributes;
  APIFlags: Longint;
begin
  if Open then
    if Action and open_CreateIfNew <> 0 then
      APIFlags := open_Always       // Open or create
    else if Action and open_TruncateIfExists <> 0 then
      APIFlags := truncate_existing // Open and truncate
    else
      APIFlags := open_Existing     // Open; fail if no file
  else
    if Action and create_TruncateIfExists <> 0 then
      APIFlags := create_Always     // Create and truncate
    else
      APIFlags := create_New;       // Create; fail if exists

  SA.nLength := SizeOf(SA);
  SA.lpSecurityDescriptor := nil;
  SA.bInheritHandle := True;
  Handle := CreateFile(AnsiFn(FileName), AccessMode[Mode and 3], ShareMode[(Mode and $F0) shr 4],
      @SA, APIFlags, file_attribute_Normal, 0);
  Result := SetResult(Handle <> invalid_Handle_Value);
end;

function SysFileOpen(FileName: PChar; Mode: Longint; var Handle: Longint): Longint;
var
  SA: TSecurityAttributes;
begin
  SA.nLength := SizeOf(SA);
  SA.lpSecurityDescriptor := nil;
  SA.bInheritHandle := True;
  Handle := CreateFile(AnsiFn(FileName), AccessMode[Mode and 3], ShareMode[(Mode and $F0) shr 4],
    @SA, open_Existing, file_attribute_Normal, 0);
  Result := SetResult(Handle <> invalid_Handle_Value);
end;

function SysFileCreate(FileName: PChar; Mode,Attr: Longint; var Handle: Longint): Longint;
var
  SA: TSecurityAttributes;
begin
  SA.nLength := SizeOf(SA);
  SA.lpSecurityDescriptor := nil;
  SA.bInheritHandle := True;
  Handle := CreateFile(AnsiFn(FileName), AccessMode[Mode and 3], ShareMode[(Mode and $F0) shr 4],
    @SA, create_Always, file_attribute_Normal, 0);
  Result := SetResult(Handle <> invalid_Handle_Value);
end;

function SysFileCopy(_Old, _New: PChar; _Overwrite: Boolean): Boolean;
begin
  Result := CopyFile(_Old, _New, not _Overwrite);
end;

function SysFileSeek(Handle,Distance,Method: Longint; var Actual: Longint): Longint;
begin
  Actual := SetFilePointer(Handle, Distance, nil, Method);
  Result := SetResult(Actual <> $FFFFFFFF);
end;

function SysFileRead(Handle: Longint; var Buffer; Count: Longint; var Actual: Longint): Longint;
begin
  Result := SetResult(ReadFile(Handle, Buffer, Count, DWord(Actual), nil));
end;

function SysFileWrite(Handle: Longint; const Buffer; Count: Longint; var Actual: Longint): Longint;
var
  sbi: TConsoleScreenBufferInfo;
begin
  Result := SetResult(WriteFile(Handle, Buffer, Count, DWord(Actual), nil));
  if (tidCursor <> -1) and (Handle = SysConOut) then
    begin
      // Writeln without Crt unit: Update cursor position variable
      GetConsoleScreenBufferInfo(SysConOut, sbi);
      CurXPos := sbi.dwCursorPosition.x;
      CurYPos := sbi.dwCursorPosition.y;
    end;
end;

function SysFileSetSize(Handle,NewSize: Longint): Longint;
var
  CurPos: Longint;
begin
  CurPos := SetFilePointer(Handle, 0, nil, file_Current);
  Result := SetResult((CurPos <> $FFFFFFFF) and
    (SetFilePointer(Handle, NewSize, nil, file_Begin) <> $FFFFFFFF) and
    SetEndOfFile(Handle) or
    (SetFilePointer(Handle, CurPos, nil, file_Begin) <> $FFFFFFFF));
end;

function SysFileClose(Handle: Longint): Longint;
begin
  Result := SetResult(CloseHandle(Handle));
end;

function SysFileFlushBuffers(Handle: Longint): Longint;
begin
  Result := SetResult(FlushFileBuffers(Handle));
end;

function SysFileDelete(FileName: PChar): Longint;
begin
  Result := SetResult(DeleteFile(AnsiFn(FileName)));
end;

function SysFileMove(OldName,NewName: PChar): Longint;
begin
  Result := SetResult(MoveFile(OldName, NewName));
end;

function SysFileIsDevice(Handle: Longint): Longint;
var
  HandleType: Longint;
begin
  HandleType := GetFileType(Handle);
  case HandleType of
  0,1 : Result := 0; // File;
    2 : Result := 1; // Device
    3 : Result := 2; // Pipe
  end;
end;

function SysDirGetCurrent(Drive: Longint; Path: PChar): Longint;
var
  DriveName: array[0..3] of Char;
  Buffer: array[0..259] of Char;
begin
  // !! Compiler problem? Result is set by GetCurrentDirectory call!
  Result := 0;
  if Drive <> 0 then
  begin
    DriveName[0] := Chr(Drive + (Ord('A') - 1));
    DriveName[1] := ':';
    DriveName[2] := #0;
    GetCurrentDirectory(SizeOf(Buffer), Buffer);
    SetCurrentDirectory(DriveName);
  end;
  GetCurrentDirectory(260, Path);
  StrCopy( Path, OemFn(Path) );
  if Drive <> 0 then
    SetCurrentDirectory(Buffer);
end;

function SysDirSetCurrent(Path: PChar): Longint;
begin
  if Path^ = #0 then
    Result := 0 // Otherwise returns rc = 161: Bad path name
  else
    Result := SetResult(SetCurrentDirectory(AnsiFn(Path)));
end;

function SysDirCreate(Path: PChar): Longint;
begin
  Result := SetResult(CreateDirectory(AnsiFn(Path), nil));
end;

function SysDirDelete(Path: PChar): Longint;
begin
  Result := SetResult(RemoveDirectory(AnsiFn(Path)));
end;

function SysMemAvail: Longint;
var
  Status: TMemoryStatus;
begin
  Status.dwLength := SizeOf(TMemoryStatus);
  GlobalMemoryStatus(Status);
  with Status do
  begin
    Result := dwAvailPhys + dwAvailPageFile;
    if Result > dwAvailVirtual then
      Result := dwAvailVirtual;
  end;
end;

function SysMemAlloc(Size,Flags: Longint; var MemPtr: Pointer): Longint;
begin
  MemPtr := VirtualAlloc(nil, Size, Flags, page_ReadWrite);
  Result := SetResult(MemPtr <> nil);
end;

function SysMemFree(MemPtr: Pointer): Longint;
begin
  Result := SetResult(VirtualFree(MemPtr, 0, mem_Release));
end;

function SysSysMsCount: Longint;
begin
  Result := GetTickCount;
end;

procedure SysSysSelToFlat(var P: Pointer);
begin
  // Do nothing; n/a for Win32
end;

procedure SysSysFlatToSel(var P: Pointer);
begin
  // Do nothing; n/a for Win32
end;

function SysCtrlSelfAppType: Longint;
var
  F       : File;
  lExeHdr : TImageDosHeader;
  lPEHdr  : TImageNtHeaders;
  SaveMode: Integer;
begin
  // Set default return value: GUI
  Result := 3;

  // Attempt to read information from PE file header.  This only works
  // if the file has not been compressed or otherwise manipulated.
  SaveMode := FileMode;
  FileMode := $40;          // Read-only, deny-none
  Assign(F, ParamStr(0));
  Reset(F, 1);
  if IOResult = 0 then
    begin
      BlockRead(f, lExeHdr, SizeOf(lExeHdr));

      if (IOResult = 0) and (lExeHdr.e_Magic = image_DOS_Signature) then
        begin
          Seek(F, lExeHdr.e_lfanew);
          BlockRead(F, lExeHdr.e_magic, SizeOf(lExeHdr.e_magic));
        end
      else
        lExeHdr.e_lfanew := 0;

      Seek(F, lExeHdr.e_lfanew);
      if (IOResult = 0) and (lExeHdr.e_magic = image_NT_Signature) then
        begin
          BlockRead(F, lPEHdr, SizeOf(lPEHdr));
          if (IOResult = 0) and (lPEHdr.Signature = image_NT_Signature) then
            if lPEHdr.OptionalHeader.SubSystem = image_Subsystem_Windows_CUI then
              Result := 2; // Text mode
        end;
      Close(F);
      InOutRes := 0;
    end;
  FileMode := SaveMode;
end;

function SysGetThreadId: Longint;
begin
  Result := GetCurrentThreadId;
end;

function SysCtrlKillThread(Handle: Longint): Longint;
begin
  Result := SetResult(TerminateThread(Handle, 0));
end;

function SysCtrlSuspendThread(Handle: Longint): Longint;
begin
  Result := SetResult(SuspendThread(Handle) <> $FFFFFFFF);
end;

function SysCtrlResumeThread(Handle: Longint): Longint;
begin
  Result := SetResult(ResumeThread(Handle) <> $FFFFFFFF);
end;

procedure SysCtrlExitThread(ExitCode: Longint);
var
  P: Pointer;
type
  TExitThread = procedure(ExitCode: Longint) stdcall;
begin
  P := QueryProcAddr('ExitThread', True);
  if P <> nil then
    TExitThread(P)(ExitCode)
  else
    SysCtrlExitProcess(ExitCode);
end;

procedure SysCtrlExitProcess(ExitCode: Longint);
begin
  ExitProcess(ExitCode);
end;

function SysCtrlCreateThread(Attrs: Pointer; StackSize: Longint; Func,Param: Pointer; Flags: Longint; var Tid: Longint): Longint;
begin
  Result := SetResult(CreateThread(Attrs, StackSize, Func, Param, Flags, Tid) <> 0);
end;

function SysCtrlGetModuleName(Handle: Longint; Buffer: PChar): Longint;
begin
  SetResult(GetModuleFileName(0, Buffer, 260) <> 0);
end;

var
  SysCritSec: TRTLCriticalSection;
  InitCritSec: Boolean;

procedure SysCtrlEnterCritSec;
begin
  if not InitCritSec then
  begin
    InitializeCriticalSection(SysCritSec);
    InitCritSec := True;
  end;
  EnterCriticalSection(SysCritSec);
end;

procedure SysCtrlLeaveCritSec;
begin
  LeaveCriticalSection(SysCritSec);
end;

function GetParamStr(P: PChar; var Param: ShortString): PChar;
var
  Len: Longint;
begin
  Result := P;
  repeat
    while Result^ in [#1..' '] do
      Inc(Result);
    if PSmallWord(Result)^ = (Ord('"') shl 8 + Ord('"')) then
      Inc(Result, 2)
    else
      Break;
  until False;
  Len := 0;
  while Result^ > ' ' do
    if Result^ = '"' then
      begin
        Inc(Result);
        while not (Result^ in [#0,'"']) do
        begin
          Inc(Len);
          Param[Len] := Result^;
          Inc(Result);
        end;
        if Result^ <> #0 then
          Inc(Result);
      end
    else
      begin
        Inc(Len);
        Param[Len] := Result^;
        Inc(Result);
      end;
  Param[0] := Chr(Len);
end;

function SysCmdln: PChar;
begin
  Result := GetCommandLine;
end;

function SysCmdlnCount: Longint;
var
  P: PChar;
  S: ShortString;
begin
  P := SysCmdln;
  Result := -1;
  repeat
    P := GetParamStr(P, S);
    if S = '' then
      Exit;
    Inc(Result);
  until False;
end;

procedure SysCmdlnParam(Index: Longint; var Param: ShortString);
var
  I: Longint;
  P: PChar;
  Buffer: array[0..260] of Char;
begin
  I := Index;
  if I = 0 then
    begin
      SysCtrlGetModuleName(0, Buffer);
      P := Buffer;
      Param := '';
      while (P^ <> #0) and (I < 255) do
      begin
        Inc(I);
        Param[I] := P^;
        Inc(P);
      end;
      SetLength(Param, I);
    end
  else
    begin
      // Skip ParamStr(0)
      P := SysCmdln;// + Length(ParamStr(0));
      repeat
        P := GetParamStr(P, Param);
        if (I = 0) or (Param = '') then
          Exit;
        Dec(I);
      until False;
    end;
end;

function SysCtrlGetTlsMapMem: Pointer;
var
  IsNew: Boolean;
  MapHandle: Longint;
  SharedMemName: record
    L0: Longint;
    L1: Longint;
    L2: Longint;
    ID: array[0..11] of Char;
  end;
  P: Pointer;
type
  TOpenFileMapping = function(Acc: DWord; Inherit: Bool; Name: PChar): THandle stdcall;

begin
  SharedMemName.L0 := Ord('S') + Ord('H') shl 8 + Ord('A') shl 16 + Ord('R') shl 24;
  SharedMemName.L1 := Ord('E') + Ord('D') shl 8 + Ord('M') shl 16 + Ord('E') shl 24;
  SharedMemName.L2 := Ord('M') + Ord('4') shl 8 + Ord('V') shl 16 + Ord('R') shl 24;
  Str(GetCurrentProcessID, SharedMemName.ID);
  MapHandle := 0;
  IsNew := False;
  P := QueryProcAddr('OpenFileMappingA', True);
  if P = nil then
    begin
      GetMem(Result, SharedMemSize);
      IsNew := True;
    end
  else
    begin
      MapHandle := TOpenFileMapping(P)(file_map_Read+file_map_Write, False, PChar(@SharedMemName));
      if MapHandle = 0 then
      begin
        MapHandle := CreateFileMapping($FFFFFFFF, nil, page_ReadWrite, 0, SharedMemSize, PChar(@SharedMemName));
        IsNew := True;
      end;
      Result := MapViewOfFile(MapHandle, file_map_Read+file_map_Write, 0, 0, 0);
    end;
  if IsNew then
  begin
    FillChar(Result^, SharedMemSize, $FF);
    FillChar(Result^, SizeOf(TSharedMem), 0);
    with PSharedMem(Result)^ do
      begin
        // Set up pointers to functions to use when allocating memory
        TlsMemMgr := System.GetPMemoryManager;
        // Set up pointer to function managing the TlsSemaphore
        TlsSemMgr := @SysSysWaitSem;
        // Initialise the TlsSemaphore
        TlsSemaphore := 0;
      end;
  end;
end;

function SysGetEnvironment: PChar;
begin
  Result := GetEnvironmentStrings;
end;

function SysOsVersion: Longint;
begin
  Result := SmallWord(GetVersion);
end;

function SysPlatformID: Longint;
var
  OSVersionInfo: TOSVersionInfo;
begin
  OSVersionInfo.dwOSVersionInfoSize := SizeOf(OSVersionInfo);
  GetVersionEx(OSVersionInfo);
  Result := OSVersionInfo.dwPlatformId;
end;

procedure SysGetDateTime(Year,Month,Day,DayOfWeek,Hour,Minute,Second,MSec: PLongint);
var
  DT: TSystemTime;
begin
  GetLocalTime(DT);
  if Year <> nil then Year^ := DT.wYear;
  if Month <> nil then Month^ := DT.wMonth;
  if Day <> nil then Day^ := DT.wDay;
  if DayOfWeek <> nil then DayOfWeek^ := DT.wDayOfWeek;
  if Hour <> nil then Hour^ := DT.wHour;
  if Minute <> nil then Minute^ := DT.wMinute;
  if Second <> nil then Second^ := DT.wSecond;
  if MSec <> nil then MSec^ := DT.wMilliseconds;
end;

procedure SysSetDateTime(Year,Month,Day,Hour,Minute,Second,MSec: PLongint);
var
  DT: TSystemTime;
begin
  GetLocalTime(DT);
  if Year <> nil then DT.wYear := Year^;
  if Month <> nil then DT.wMonth := Month^;
  if Day <> nil then DT.wDay := Day^;
  if Hour <> nil then DT.wHour := Hour^;
  if Minute <> nil then DT.wMinute := Minute^;
  if Second <> nil then DT.wSecond := Second^;
  if MSec <> nil then DT.wMilliseconds := MSec^;
  SetLocalTime(DT);
end;

function SysVerify(SetValue: Boolean; Value: Boolean): Boolean;
begin
  Result := False;
end;

function SysDiskFreeLong(Drive: Byte): TQuad;
var
  RootPath: array[0..3] of Char;
  RootPtr: PChar;
  SectorsPerCluster,BytesPerSector,FreeClusters,TotalClusters: DWord;
begin
  RootPtr := nil;
  if Drive > 0 then
  begin
    RootPath[0] := Char(Drive + (Ord('A') - 1));
    RootPath[1] := ':';
    RootPath[2] := '\';
    RootPath[3] := #0;
    RootPtr := RootPath;
  end;
  if GetDiskFreeSpace(RootPtr, SectorsPerCluster, BytesPerSector, FreeClusters, TotalClusters) then
    Result := 1.0 * SectorsPerCluster * BytesPerSector * FreeClusters
  else
    Result := -1;
end;

function SysDiskSizeLong(Drive: Byte): TQuad;
var
  RootPath: array[0..3] of Char;
  RootPtr: PChar;
  SectorsPerCluster,BytesPerSector,FreeClusters,TotalClusters: DWord;
begin
  RootPtr := nil;
  if Drive > 0 then
  begin
    RootPath[0] := Char(Drive + (Ord('A') - 1));
    RootPath[1] := ':';
    RootPath[2] := '\';
    RootPath[3] := #0;
    RootPtr := RootPath;
  end;
  if GetDiskFreeSpace(RootPtr, SectorsPerCluster, BytesPerSector, FreeClusters, TotalClusters) then
    Result := 1.0 *SectorsPerCluster * BytesPerSector * TotalClusters
  else
    Result := -1;
end;

function SysGetFileAttr(FileName: PChar; var Attr: Longint): Longint;
begin
  Attr := GetFileAttributes(AnsiFn(FileName));
  Result := SetResult(Attr <> -1);
  if Attr = -1 then
    Inc(Attr);
end;

function SysSetFileAttr(FileName: PChar; Attr: Longint): Longint;
begin
  Result := SetResult(SetFileAttributes(AnsiFn(FileName), Attr));
end;

function SysGetFileTime(Handle: Longint; var Time: Longint): Longint;
var
  FileTime, LocalFileTime: TFileTime;
begin
  Result := SetResult(GetFileTime(Handle, nil, nil, @FileTime) and
    FileTimeToLocalFileTime(FileTime, LocalFileTime) and
    FileTimeToDosDateTime(LocalFileTime, TDateTimeRec(Time).FDate, TDateTimeRec(Time).FTime));
end;

function SysSetFileTime(Handle: Longint; Time: Longint): Longint;
var
  LocalFileTime, FileTime: TFileTime;
begin
  Result := SetResult(DosDateTimeToFileTime(TDateTimeRec(Time).FDate, TDateTimeRec(Time).FTime, LocalFileTime) and
    LocalFileTimeToFileTime(LocalFileTime, FileTime) and
    SetFileTime(Handle, nil, nil, @FileTime));
end;

function DoFindFile(var F: TOSSearchRec; IsPChar: Boolean): Longint;
var
  LocalFileTime: TFileTime;
  ExclAttr: Longint;
  InclAttr: Longint;
begin
  // Extract Include/Exclude attributes from F.ExcludeAttr field
  ExclAttr := not F.ExcludeAttr and (file_Attribute_Hidden or file_Attribute_System or $8 or file_Attribute_Directory or file_Attribute_Archive);
  InclAttr := (F.ExcludeAttr and $FF00) shr 8;
  // Make sure attributes are not both excluded and included
  ExclAttr := ExclAttr and not InclAttr;
  with F do
  begin
    // Reject entries where
    // - Attributes that are excluded are present.
    // - Attributes that must be present are not all there
    while (FindData.dwFileAttributes and ExclAttr <> 0) or
      (FindData.dwFileAttributes and InclAttr <> InclAttr) do
      if not FindNextFile(Handle, FindData) then
      begin
        Result := GetLastError;
        Exit;
      end;
    FileTimeToLocalFileTime(FindData.ftLastWriteTime, LocalFileTime);
    FileTimeToDosDateTime(LocalFileTime, TDateTimeRec(Time).FDate, TDateTimeRec(Time).FTime);
    Size := FindData.nFileSizeLow;
    Attr := FindData.dwFileAttributes;
    // Convert filename to OEM character set
    CharToOem(FindData.cFileName, FindData.cFileName);
    if IsPChar then
      StrCopy(PChar(@Name), FindData.cFileName)
    else
      Name := StrPas(FindData.cFileName);
  end;
  Result := 0;
end;

function SysFindFirst(Path: PChar; Attr: Longint; var F: TOSSearchRec; IsPChar: Boolean): Longint;
begin
  F.ExcludeAttr := Attr;
  F.Handle := FindFirstFile(Path, F.FindData);
  if F.Handle <> invalid_Handle_Value then
    begin
      Result := DoFindFile(F, IsPChar);
      if Result <> 0 then
        begin
          FindClose(F.Handle);
          F.Handle := invalid_Handle_Value;
        end;
    end
  else
    Result := GetLastError;
end;

function SysFindNext(var F: TOSSearchRec; IsPChar: Boolean): Longint;
begin
  if FindNextFile(F.Handle, F.FindData) then
    Result := DoFindFile(F, IsPChar)
  else
    Result := GetLastError;
end;

function SysFindClose(var F: TOSSearchRec): Longint;
begin
  if F.Handle = invalid_Handle_Value then
    Result := 0
  else
    Result := SetResult(Windows.FindClose(F.Handle));
  F.Handle := invalid_Handle_Value;
end;

// Check if file exists; if it does, update FileName parameter
// to include correct case of existing file
function SysFileAsOS(FileName: PChar): Boolean;
var
  Handle: THandle;
  FindData: TWin32FindData;
  LocalFileTime: TFileTime;
  P: PChar;
begin
  Handle := FindFirstFile(AnsiFn(FileName), FindData);
  if Handle <> invalid_Handle_Value then
    begin
      if FindData.cFileName[0] <> #0 then
        begin
          // Replace filename part with data returned by Windows
          P := StrRScan(FileName, '\');
          if P = nil then
            P := FileName
          else
            inc(P); // Point to first character of file name
          strcopy(P, FindData.cFileName);
        end;
      FindClose(Handle);
      Result := True;
    end
  else
    Result := False;
end;

function SysFileSearch(Dest,Name,List: PChar): PChar;
var
  I, P, L: Integer;
  Buffer: array[0..259] of Char;
begin
  Result := Dest;
  StrCopy(Buffer, Name);
  P := 0;
  L := StrLen(List);
  while True do
  begin
    if SysFileAsOS(Buffer) then
    begin
      SysFileExpand(Dest, Buffer);
      Exit;
    end;
    while (P < L) and (List[P] = ';') do
      Inc(P);
    if P >= L then
      Break;
    I := P;
    while (P < L) and (List[P] <> ';') do
      Inc(P);
    StrLCopy(Buffer, List + I, P - I);
    if not (List[P-1] in [':', '\']) then
      StrLCat(Buffer, '\', 259);
    StrLCat(Buffer, Name, 259);
  end;
  Dest^ := #0;
end;

function SysFileExpand(Dest,Name: PChar): PChar;
var
  L: Longint;
  NameOnly: PChar;
begin
  if strlen(Name) = 0 then
    SysDirGetCurrent(0, Dest)
  else
    if GetFullPathName(Name, 260, Dest, NameOnly) = 0 then
      StrCopy(Dest, Name) // API failed; copy name to dest
    else
      if (StrComp(Name, '.') <> 0) and (StrComp(Name, '..') <> 0) then
        begin
          L := StrLen(Name);
          if (L > 0) and (Name[L-1] = '.') then
          begin
            L := StrLen(Dest);
            if (L > 0) and (Dest[L-1] <> '.') then
            begin
              Dest[L] := '.';
              Dest[L+1] := #0;
            end;
          end;
        end;
  Result := Dest;
end;

threadvar
  ProcessInfo: TProcessInformation;
  LastAsync: Boolean;

function SysExecute(Path,CmdLine,Env: PChar; Async: Boolean; PID: PLongint; StdIn,StdOut,StdErr: Longint): Longint;
var
  P: PChar;
  Flags: Longint;
  StartupInfo: TStartupInfo;
  CmdLineBuf: array [0..8191] of Char;
begin
  P := CmdLineBuf;
  P^ := '"';                   // Quotes to support spaces
  inc(P);
  P := StrECopy(P, Path);      // 'Path'#0
  P^ := '"';
  inc(P);
  P^ := ' ';
  StrCopy(P+1, CmdLine);                // 'Path CommandLine'#0
  FillChar(StartupInfo, SizeOf(TStartupInfo), 0);
  with StartupInfo do
  begin
    cb := SizeOf(TStartupInfo);
    dwFlags := startf_UseShowWindow;
    wShowWindow := sw_ShowNormal;
    if StdIn = -1 then
      hStdInput := SysFileStdIn
    else
      hStdInput := StdIn;
    if StdOut = -1 then
      hStdOutput := SysFileStdOut
    else
      hStdOutput := StdOut;
    if StdErr = -1 then
      hStdError := SysFileStdErr
    else
      hStdError := StdErr;
    if (StdIn <> - 1) or (StdOut <> -1) or (StdErr <> -1) then
      Inc(dwFlags, startf_UseStdHandles);
  end;
  Flags := normal_Priority_Class;
  LastAsync := Async;
  Result := SetResult(CreateProcess(Path, CmdLineBuf, nil, nil, True, Flags, Env, nil, StartupInfo, ProcessInfo));
  if Result = 0 then
    if Async then
      begin
        if PID <> nil then
          PID^ := ProcessInfo.hProcess;
      end
    else
      WaitForSingleObject(ProcessInfo.hProcess, Infinite);
end;

function SysExitCode: Longint;
begin
  if LastAsync then
    WaitForSingleObject(ProcessInfo.hProcess, Infinite);
  GetExitCodeProcess(ProcessInfo.hProcess, Result);
end;

procedure SysGetCaseMap(TblLen: Longint; Tbl: PChar );
begin
  CharUpperBuff(Tbl, TblLen);
end;

procedure SysGetWeightTable(TblLen: Longint; WeightTable: PChar);
var
  I: Longint;

begin
  // !!! Must use Win32 function
  for I := 0 to pred(TblLen) do
    begin
      WeightTable^ := Chr(i);
      inc(WeightTable);
    end;
end;

function SysGetCodePage: Longint;
var
  P: Pointer;
type
  TGetKBCodePage = function: Longint;
begin
  P := QueryProcAddr('GetKBCodePage', False);
  if P = nil then
    Result := 0
  else
    Result := TGetKBCodePage(P);
end;

function SysCompareStrings(s1, s2: PChar; l1, l2: Longint; IgnoreCase: Boolean): Longint;
begin
  if IgnoreCase then
    Result := CompareString(Locale_User_Default, norm_ignorecase,S1, l1, s2, l2)-2
  else
    Result := CompareString(Locale_User_Default, 0, S1, l1, s2, l2)-2;
end;

procedure SysChangeCase(Source, Dest: PChar; Len: Longint; NewCase: TCharCase);
var
  I: Longint;
begin
  if NewCase in [ccLower, ccUpper] then
    begin
      i := 0;
      while i < Len do
        begin
          if NewCase = ccLower then
            if Source^ in ['A'..'Z'] then
              Dest^ := chr(ord(Source^)+32)
            else
              Dest^ := Source^
          else
            if Source^ in ['a'..'z'] then
              Dest^ := chr(ord(Source^)-32)
            else
              Dest^ := Source^;
          inc(i);
          inc(Source);
          inc(Dest);
        end;
    end
  else
    begin
      // AnsiUpper and AnsiLower
      StrLCopy(Dest, Source, Len);
      if NewCase = ccAnsiLower then
        CharLowerBuff(Dest, Len)
      else
        CharUpperBuff(Dest, Len);
    end;
end;

function SysLowerCase(s: PChar): PChar;
begin
  Result := CharLower(s);
end;

function SysUpperCase(s: PChar): PChar;
begin
  Result := CharUpper(s);
end;

var
  PrevXcptProc: Pointer;

function SignalHandler(Report:       PExceptionRecord;
                       Registration: Pointer;
                       Context:      PContext;
                       P:            Pointer): Longint; stdcall;
begin
  if (Report^.ExceptionCode = status_Control_C_Exit) and Assigned(CtrlBreakHandler) and CtrlBreakHandler then
    Result := 1
  else
    Result := 0;
  XcptProc := PrevXcptProc;
end;

function CtrlHandler(CtrlType: DWord): Bool; stdcall;
begin
  if Assigned(CtrlBreakHandler) and CtrlBreakHandler then
    Result := True
  else
    Result := False;
end;

procedure SysCtrlSetCBreakHandler;
begin
  PrevXcptProc := XcptProc;
  XcptProc := @SignalHandler;
  SetConsoleCtrlHandler(@CtrlHandler, True);
end;

function SysFileIncHandleCount(Count: Longint): Longint;
begin
  // Return 0, indicating success.  In Win95/NT, the number of file handles
  // is limited by available physical memory only.
  Result := 0;
end;

procedure DoSetCursorPosition;
var
  CurPos: TCoord;
begin
  CurPos.x := CurXPos;
  CurPos.y := CurYPos;
  SetConsoleCursorPosition(SysConOut, CurPos);
end;

function CursorThreadFunc(P: Pointer): Longint;
var
  LastX, LastY: Longint;
begin
  LastX := -1;
  LastY := -1;
  repeat
    SemWaitEvent(semCursor, 300);
    if (CurXPos <> LastX) or (CurYPos <> LastY) then
      begin
        DoSetCursorPosition;
        LastX := CurXPos;
        LastY := CurYPos;
      end;
  until tidCursor = -2;
  tidCursor := -1;
end;

procedure CursorThreadExitProc;
begin
  // Force cursor thread to terminate
  tidCursor := -2;
  SemPostEvent(semCursor);
  // Update cursor position
  DoSetCursorPosition;
end;

procedure InitialiseKeyboardHandler;
begin
  if hKbdDll = -1 then // First try - attempt load
    begin
      hKbdDll := LoadLibrary(KbdDllName);
      if hKbdDll <> 0 then
        begin
          @pKbdInit := GetProcAddress(hKbdDll, name_KbdInit);
          @pKbdUpdateEventQueues := GetProcAddress(hKbdDll, name_KbdUpdateEventQueue);
        end;
      // If any of the entry points were not found in the DLL, point them
      // to statically linked default handlers
      if not assigned(pKbdInit) or not assigned(pKbdUpdateEventQueues) then
        begin
          @pKbdInit := @VpKbdW32.KbdInit;
          @pKbdUpdateEventQueues := @VpKbdW32.KbdUpdateEventQueues;
        end;
      pKbdInit(pSysKeyCount, pSysKeyQue, pSysShiftState, pSysMouCount, pSysMouQue);
    end;
end;

procedure InitialiseConsole;
begin
  SysConIn  := SysFileStdIn; //CreateFile('CONIN$' , generic_Read or generic_Write, file_share_Read, nil, open_Existing, file_attribute_Normal, 0);
  SysConOut := SysFileStdOut; //CreateFile('CONOUT$', generic_Read or generic_Write, file_share_Read or file_share_Write, nil, open_Existing, file_attribute_Normal, 0);

  InitialiseKeyboardHandler;
end;


const
  CrtScanCode: Byte = 0;

function SysKeyPressed: Boolean;
begin
  if CrtScanCode <> 0 then
    Result := True
  else
    begin
      InitialiseKeyboardHandler;
      pKbdUpdateEventQueues;
      Result := pSysKeyCount^ <> 0;
    end;
end;

function SysPeekKey(Var Ch: Char): Boolean;
begin
  pKbdUpdateEventQueues;
  if pSysKeyCount^ > 0 then
    Result := False
  else
    begin
      Result := True;
      if Lo(pSysKeyQue^[0].skeKeyCode) in [0,$E0] then
        Ch := #0
      else
        Ch := Chr(Lo(pSysKeyQue^[0].skeKeyCode));
    end;
end;

function SysReadKey: Char;
var
  EventCount: DWord;
  InRec: TInputRecord;
begin
  if CrtScanCode <> 0 then
    begin
      Result := Chr(CrtScanCode);
      CrtScanCode := 0;
    end
  else
    begin
      InitialiseKeyboardHandler;
      repeat
        pKbdUpdateEventQueues;
        if pSysKeyCount^ = 0 then
          WaitForSingleObject(SysConIn, infinite);
      until pSysKeyCount^ <> 0;
      Dec(pSysKeyCount^);
      if Lo(pSysKeyQue^[0].skeKeyCode) in [0,$E0] then
        begin
          CrtScanCode := Hi(pSysKeyQue^[0].skeKeyCode);
          Result := #0;
        end
      else
        Result := Chr(Lo(pSysKeyQue^[0].skeKeyCode));
      Move(pSysKeyQue^[1], pSysKeyQue^[0], pSysKeyCount^ * SizeOf(TSysKeyEvent));
    end;
end;

procedure SysFlushKeyBuf;
begin
  InitialiseKeyboardHandler;
  CrtScanCode := 0;
  pSysKeyCount^ := 0;
  FlushConsoleInputBuffer(SysConIn);
end;

procedure InitialiseCursorThread;
var
  sbi: TConsoleScreenBufferInfo;
begin
  if tidCursor = -1 then
    begin
      // Get initial cursor position
      GetConsoleScreenBufferInfo(SysConOut, sbi);
      CurXPos := sbi.dwCursorPosition.x;
      CurYPos := sbi.dwCursorPosition.y;

      semCursor := SemCreateEvent(nil, false, false);
      BeginThread(nil, 16384, CursorThreadFunc, nil, 0, tidCursor );
      SemPostEvent(semCursor);
      AddExitProc(CursorThreadExitProc);
    end;
end;

procedure SysWrtCharStrAtt(CharStr: Pointer; Len, X, Y: SmallWord; var Attr: Byte);
var
  Buffer: Array[0..255] of TWin32Cell;
  BufferSize,
  BufferCoord: TCoord;
  WriteRegion: TSmallRect;
  BufNext: ^TWin32Cell;
  I: Longint;
begin
  InitialiseCursorThread;
  BufNext := @Buffer;
  for i := 0 to Len-1 do
    begin
      BufNext^.Attr := Attr;
      BufNext^.Ch := Ord( PChar(CharStr)^ );
      inc(PChar(CharStr));
      inc(BufNext);
    end;
  with BufferSize do
    begin
      x := Len;
      y := 1;
    end;
  with BufferCoord do
    begin
      x := 0;
      y := 0;
    end;
  with WriteRegion do
    begin
      Left := x;
      Top := y;
      Right := x+Len-1;
      Bottom := y;
    end;
  WriteConsoleOutput( SysConOut, @Buffer, BufferSize, BufferCoord, WriteRegion );
end;

function SysReadAttributesAt(x,y: SmallWord): Byte;
var
  WasRead: Longint;
  Coor: TCoord;
  Temp: SmallWord;
begin
  SysTVInitCursor;
  Coor.x := x;
  Coor.y := y;
  ReadConsoleOutputAttribute(SysConOut, @Temp, 1, Coor, WasRead);
  Result := Temp;
end;

function SysReadCharAt(x,y: SmallWord): Char;
var
  WasRead: Longint;
  Coor: TCoord;
begin
  SysTVInitCursor;
  Coor.x := x;
  Coor.y := y;
  ReadConsoleOutputCharacter(SysConOut, @Result, 1, Coor, WasRead);
  if WasRead = 0 then
    Result := #0;
end;

procedure SysScrollUp(X1,Y1,X2,Y2,Lines,Cell: SmallWord);
var
  Cliprect,
  ScrollRect: TSmallRect;
  DestCoord: TCoord;
  Fill: TWin32Cell;
  i: Integer;
begin
  if SysPlatform = -1 then
    SysPlatform := SysPlatformID;
  Fill.ch := Lo(Cell);
  Fill.Attr := Hi( Cell );
  ScrollRect.Left := X1;
  ScrollRect.Top := Y1;
  ScrollRect.Right := X2;
  ScrollRect.Bottom := Y2;
  ClipRect := ScrollRect;
  if SysPlatform = VER_PLATFORM_WIN32_NT then
    begin
      DestCoord.x := X1;       // This API works in Windows NT
      DestCoord.y := Y1-Lines;
      ScrollConsoleScreenBuffer(SysConOut, ScrollRect, @ClipRect, DestCoord, PCharInfo(@Fill)^);
    end
  else
    begin
      if Lines > 1 then
        for i := 1 to 2 do // Half a screen at a time; bug in Win95
          begin
            DestCoord.x := X1;
            DestCoord.y := Y1-Lines div 2;
            ScrollConsoleScreenBuffer(SysConOut, ScrollRect, @ClipRect, DestCoord, PCharInfo(@Fill)^);
          end;
      if odd(Lines) then // Also do last line, if odd number
        begin
          DestCoord.x := X1;
          DestCoord.y := Y1-1;
          ScrollConsoleScreenBuffer(SysConOut, ScrollRect, @ClipRect, DestCoord, PCharInfo(@Fill)^);
        end;
    end;
end;

procedure SysScrollDn(X1,Y1,X2,Y2,Lines,Cell: SmallWord);
var
  ScrollRect: TSmallRect;
  DestCoord: TCoord;
  Fill: TWin32Cell;
begin
  Fill.ch := Lo(Cell);
  Fill.Attr := Hi(Cell);
  ScrollRect.Left := X1;
  ScrollRect.Top := Y1;
  ScrollRect.Right := X2;
  ScrollRect.Bottom := Y2-Lines;
  DestCoord.x := X1;
  DestCoord.y := Y1+Lines;
  ScrollConsoleScreenBuffer(SysConOut, ScrollRect, nil, DestCoord, PCharInfo(@Fill)^);
end;

procedure SysGetCurPos(var X,Y: SmallWord);
begin
  if CurXPos = -1 then
    InitialiseCursorThread;
  X := CurXPos;
  Y := CurYPos;
end;

function SysTVDetectMouse: Longint;
begin
  Result := 2;
end;

procedure SysTVInitMouse(var X,Y: Integer);
begin
  X := 0;
  Y := 0;
end;

procedure SysTVDoneMouse(Close: Boolean);
begin
end;

procedure SysTVShowMouse; // No control over mouse pointer in Win32
begin
end;

procedure SysTVHideMouse; // No control over mouse pointer in Win32
begin
end;

procedure SysTVUpdateMouseWhere(var X,Y: Integer);
begin
end;

function SysTVGetMouseEvent(var Event: TSysMouseEvent): Boolean;
begin
  InitialiseKeyboardHandler;
  pKbdUpdateEventQueues;
  if pSysMouCount^ = 0 then
    Result := False
  else
    begin
      Dec(pSysMouCount^);
      Event := pSysMouQue^[0];
      Move(pSysMouQue^[1], pSysMouQue^[0], pSysMouCount^ * SizeOf(TSysMouseEvent));
      Result := True;
    end;
end;

procedure SysTVKbdInit;
begin
  SetConsoleMode(SysConIn, ENABLE_MOUSE_INPUT);
end;

function SysTVGetKeyEvent(var Event: TSysKeyEvent): Boolean;
begin
  InitialiseKeyboardHandler;
  pKbdUpdateEventQueues;
  if pSysKeyCount^ = 0 then
    Result := False
  else
    begin
      Dec(pSysKeyCount^);
      Event := pSysKeyQue^[0];
      Move(pSysKeyQue^[1], pSysKeyQue^[0], pSysKeyCount^ * SizeOf(TSysKeyEvent));
      Result := True;
    end;
end;

function SysTVPeekKeyEvent(var Event: TSysKeyEvent): Boolean;
begin
  InitialiseKeyboardHandler;
  pKbdUpdateEventQueues;
  if pSysKeyCount^ = 0 then
    Result := False
  else
    begin
      Event := pSysKeyQue^[0];
      Result := True;
    end;
end;

function SysTVGetShiftState: Byte;
begin
  InitialiseKeyboardHandler;
  Result := pSysShiftState^;
end;

procedure SysTVSetCurPos(X,Y: Integer);
var
  CurPos: TCoord;
begin
  CurXPos := X;
  CurYPos := Y;
  if tidCursor = -1 then
    // Set cursor position without using cursor thread
    DoSetCursorPosition
  else
    // Record cursor position; tell cursor thread to update
    SemPostEvent(semCursor);
end;

procedure SysTVSetCurType(Y1,Y2: Integer; Show: Boolean);
var
  Info: TConsoleCursorInfo;
begin
  Info.bVisible := Show;
  if Abs(Y1 - Y2) <= 1 then
    Info.dwSize := 15
  else
    Info.dwSize := 99;
  SetConsoleCursorInfo(SysConOut, Info);
end;

procedure SysTVGetCurType(var Y1,Y2: Integer; var Visible: Boolean);
var
  Info: TConsoleCursorInfo;
begin
  GetConsoleCursorInfo(SysConOut, Info);
  Visible := Info.bVisible;
  if Info.dwSize <= 25 then
    begin
      Y1 := 6;
      Y2 := 7;
    end
  else
    begin
      Y1 := 1;
      Y2 := 7;
    end;
end;

procedure WriteConsoleLine(X,Y: Integer; Len: Integer);
var
  P: PChar;
  Q: PWin32Cell;
  LineBuf: array[0..255] of TWin32Cell;
  R: TSmallRect;
  BufPos: TCoord;
  LineSize: TCoord;
begin
  InitialiseCursorThread;
  { Prepared parameters }
  LineSize.X := SysBufInfo.dwSize.X;
  LineSize.Y := 1;
  BufPos.X := 0;
  BufPos.Y := 0;
  R.Left := X;
  R.Top  := Y;
  R.Right := X + Len - 1;
  R.Bottom := Y;
  { Translate the buffer from DOS-OS/2 format to Win32 }
  P := SysScrBuf + ((Y * SysBufInfo.dwSize.X) + X) * 2;
  Q := @LineBuf;
  while Len > 0 do
  begin
    Q^.Ch := Ord(P^);
    Inc(P);
    Q^.Attr := Ord(P^);
    Inc(P);
    Inc(Q);
    Dec(Len);
  end;
  WriteConsoleOutput(SysConOut, @LineBuf, LineSize, BufPos, R);
end;

function Min(X,Y: Integer): Integer;
begin
  Result := Y;
  if X < Y then
    Result := X;
end;

procedure SysTVShowBuf(Pos,Size: Integer);
var
  I,X,Y: Integer;
begin
  Pos := Pos div 2;
  X := Pos mod SysBufInfo.dwSize.X;
  Y := Pos div SysBufInfo.dwSize.X;
  while Size > 0 do
  begin
    I := Min(SysBufInfo.dwSize.X - X, Size div 2);
    WriteConsoleLine(X, Y, I);
    Dec(Size, I * 2);
    X := 0;
    Inc(Y);
  end;
end;

procedure SysTVClrScr;
var
  I,BufSize: Integer;
begin
  BufSize := SysBufInfo.dwSize.X * SysBufInfo.dwSize.Y * 2;
  I := 0;
  while I < BufSize do
  begin
    SysScrBuf[I] := ' ';
    Inc(I);
    SysScrBuf[I] := #7;
    Inc(I);
  end;
  SysTVShowBuf(0, BufSize);
  SysTVSetCurPos(0, 0);
end;

function SysTVGetScrMode(Size: PSysPoint): Integer;
begin
  GetConsoleScreenBufferInfo(SysConOut, SysBufInfo);
  case SysBufInfo.dwSize.Y of
    25:    Result := $0003;
    43,50: Result := $0103;
    else   Result := $00FF;
  end;
  if Size <> nil then
    with Size^ do
    begin
      X := SysBufInfo.dwSize.X;
      Y := SysBufInfo.dwSize.Y;
      if Size.Y > 234 then
        Size.Y := 234;
    end;
end;

procedure SysTVSetScrMode(Mode: Integer);
var
  R: TSmallRect;
  Size: TCoord;
begin
  Size.X := 80;
  Size.Y := 25;
  if Mode and $0100 <> 0 then
    Size.Y := 50;
  SetConsoleScreenBufferSize(SysConOut, Size);
  R.Left   := 0;
  R.Top    := 0;
  R.Right  := Size.X - 1;
  R.Bottom := Size.Y - 1;
  SetConsoleWindowInfo(SysConOut, True, R);
end;

function SysTVGetSrcBuf: Pointer;
const
  First: Boolean = True;
  UpLeft: TCoord= (X:0; Y:0);
  ReadFrom: TSmallRect = (Left:0; Top:0; Right:0; Bottom:0);
var
  Size: TSysPoint;
  Coord: TCoord;
  Buffer: PWin32Cell;
  PDest: PStandardCell;
  PSrc: PWin32Cell;
  X,Y: Longint;
begin
  Result := @SysScrBuf;
  if First then
    begin
      First := False;
      SysTVGetScrMode(@Size);
      Coord.X := Size.X;
      Coord.Y := Size.Y;
      ReadFrom.Right := Size.X;
      ReadFrom.Bottom := Size.Y;
      // Read existing content of screen into buffer
      GetMem(Buffer, (Size.X+1)*(Size.Y+1)*SizeOf(TWin32Cell));
      if not ReadConsoleOutput(SysConOut, Buffer, Coord, UpLeft, ReadFrom) then
        X := GetLastError;
      // Move the data to the screen buffer in standard format
      PSrc := Buffer;
      PDest := Result;
      for Y := 0 to Size.Y-1 do
        for X := 0 to Size.X-1 do
          begin
            PDest^.Ch := chr(PSrc^.Ch);
            PDest^.Attr := byte(PSrc^.Attr);
            inc(PSrc);
            inc(PDest);
          end;
      FreeMem(Buffer);
    end;
end;

procedure SysTVInitCursor;
begin
  if SysConIn = -1 then
    InitialiseConsole;
end;

procedure SysCtrlSleep(Delay: Integer);
begin
  Sleep(Delay);
end;

function SysGetValidDrives: Longint;
begin
  Result := GetLogicalDrives;
end;

procedure SysDisableHardErrors;
begin
  SetErrorMode(sem_FailCriticalErrors);
end;

function SysKillProcess(Process: Longint): Longint;
begin
  Result := SetResult(TerminateProcess(Process, -1));
end;

function SysAllocSharedMem(Size: Longint; var MemPtr: Pointer): Longint;
begin
  Result := -1;
end;

function SysGiveSharedMem(MemPtr: Pointer): Longint;
begin
  Result := -1;
end;

function SysPipeCreate(var ReadHandle,WriteHandle: Longint; Size: Longint): Longint;
var
  SA: TSecurityAttributes;
begin
  SA.nLength := SizeOf(SA);
  SA.lpSecurityDescriptor := nil;
  SA.bInheritHandle := True;
  Result := SetResult(CreatePipe(ReadHandle, WriteHandle, @SA, Size));
end;

function SysPipePeek(Pipe: Longint; Buffer: Pointer; BufSize: Longint; var BytesRead: Longint; var IsClosing: Boolean): Longint;
var
  State: Longint;
begin
  Result := SetResult(PeekNamedPipe(Pipe, Buffer, BufSize, @BytesRead, nil, nil));
  IsClosing := WaitForSingleObject(ProcessInfo.hProcess, 0) = wait_Object_0;
end;

function SysPipeClose(Pipe: Longint): Longint;
begin
  Result := SysFileClose(Pipe);
end;

function SysLoadResourceString(ID: Longint; Buffer: PChar; BufSize: Longint): PChar;
begin
  Buffer[0] := #0;
  LoadString(HInstance, ID, Buffer, BufSize);
  Result := Buffer;
end;

function SysFileUNCExpand(Dest,Name: PChar): PChar;

  procedure GetUNCPath(FileName: PChar);
  type
    PNetResourceArray = ^TNetResourceArray;
    TNetResourceArray = array[0..MaxInt div SizeOf(TNetResource) - 1] of TNetResource;
  var
    Done: Boolean;
    I,Count,Size: Integer;
    NetHandle: THandle;
    P,NetResources: PNetResource;
    RemoteNameInfo: array[0..1023] of Byte;
    Drive: char;
  begin
    if SysPlatform <> VER_PLATFORM_WIN32_WINDOWS then
      begin
        Size := SizeOf(RemoteNameInfo);
        if WNetGetUniversalName(FileName, UNIVERSAL_NAME_INFO_LEVEL,
          @RemoteNameInfo, Size) <> NO_ERROR then
          Exit;
        StrCopy(FileName, PRemoteNameInfo(@RemoteNameInfo).lpUniversalName);
      end
    else
      begin
      { The following works around a bug in WNetGetUniversalName under Windows 95 }
        Drive := UpCase(FileName[1]);
        if (Drive < 'A') or (Drive > 'Z') or (StrLen(FileName) < 3) or
          (FileName[1] <> ':') or (FileName[2] <> '\') then
          Exit;
        if WNetOpenEnum(RESOURCE_CONNECTED, RESOURCETYPE_DISK, 0, nil, NetHandle) <> NO_ERROR then
          Exit;
        Count := -1;
        if WNetEnumResource(NetHandle, Count, nil, Size) = ERROR_MORE_DATA then
        begin
          GetMem(NetResources, Size);
          Done := False;
          P := NetResources;
          repeat
            if WNetEnumResource(NetHandle, Count, P, Size) <> NO_ERROR then
              Break;
            I := 0;
            while I < Count do
            begin
              with P^ do
                if (lpLocalName <> nil) and (UpCase(FileName[0]) = UpCase(lpLocalName[0])) then
                begin
                  I := StrLen(lpRemoteName);
                  StrMove(@FileName[I], @FileName[2], MaxInt);
                  Move(lpRemoteName^, FileName^, I);
                  Done := True;
                  Break;
                end;
              Inc(I);
              Inc(P);
            end;
          until Done;
          FreeMem(NetResources);
        end;
        WNetCloseEnum(NetHandle);
      end;
  end;

begin
  if SysPlatform = -1 then
    SysPlatform := SysPlatformID;
  SysFileExpand(Dest, Name);
  if (UpCase(Dest[0]) in ['A'..'Z']) and (Dest[1] = ':') and (Dest[2] = '\') then
    GetUNCPath(Dest);
  Result := Dest;
end;

function SysGetSystemError(Code: Longint; Buffer: PChar; BufSize: Longint;var MsgLen: Longint): PChar;
begin
  MsgLen := FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM or
    FORMAT_MESSAGE_ARGUMENT_ARRAY, nil, Code, 0, Buffer, BufSize, nil);
  Result := Buffer;
end;

function GetLocaleStr(Locale,LocaleType: Integer; Default,Dest: PChar): PChar;
begin
  if GetLocaleInfo(Locale, LocaleType, Dest, 260) <= 0 then
    StrCopy(Dest, Default);
  Result := Dest;
end;

function GetLocaleChar(Locale, LocaleType: Integer; Default: Char): Char;
var
  Buffer: array[0..1] of Char;
begin
  if GetLocaleInfo(Locale, LocaleType, @Buffer, 2) > 0 then
    Result := Buffer[0] else
    Result := Default;
end;

function SysStrToIntDef(S: PChar; Default: Integer): Integer;
var
  E: Integer;
begin
  Val(S, Result, E);
  if E <> 0 then
    Result := Default;
end;

procedure SysGetCurrencyFormat(CString: PChar; var CFormat, CNegFormat, CDecimals: Byte; var CThousandSep, CDecimalSep: Char);
var
  DefaultLCID: LCID;
  Buffer: array[0..259] of Char;
begin
  DefaultLCID := GetThreadLocale;
  GetLocaleStr(DefaultLCID, LOCALE_SCURRENCY, '', CString);
  CFormat := SysStrToIntDef(GetLocaleStr(DefaultLCID, LOCALE_ICURRENCY, '0', Buffer), 0);
  CNegFormat := SysStrToIntDef(GetLocaleStr(DefaultLCID, LOCALE_INEGCURR, '0', Buffer), 0);
  CThousandSep := GetLocaleChar(DefaultLCID, LOCALE_STHOUSAND, ',');
  CDecimalSep := GetLocaleChar(DefaultLCID, LOCALE_SDECIMAL, '.');
  CDecimals := SysStrToIntDef(GetLocaleStr(DefaultLCID, LOCALE_ICURRDIGITS, '0', Buffer), 0);
end;

procedure SysGetDateFormat(var DateSeparator: Char; ShortDateFormat, LongDateFormat: PChar);
var
  DefaultLCID: LCID;
begin
  DefaultLCID := GetThreadLocale;
  DateSeparator := GetLocaleChar(DefaultLCID, LOCALE_SDATE, '/');
  GetLocaleStr(DefaultLCID, LOCALE_SSHORTDATE, 'm/d/yy', ShortDateFormat);
  GetLocaleStr(DefaultLCID, LOCALE_SLONGDATE, 'mmmm d, yyyy', LongDateFormat);
end;

procedure SysGetTimeFormat(var TimeSeparator: Char; TimeAMString,TimePMString,ShortTimeFormat,LongTimeFormat: PChar);
var
  TimePostfix: PChar;
  DefaultLCID: LCID;
  Buffer: array[0..259] of Char;
begin
  DefaultLCID := GetThreadLocale;
  TimeSeparator := GetLocaleChar(DefaultLCID, LOCALE_STIME, ':');
  GetLocaleStr(DefaultLCID, LOCALE_S1159, 'am', TimeAMString);
  GetLocaleStr(DefaultLCID, LOCALE_S2359, 'pm', TimePMString);
  TimePostfix := '';
  if SysStrToIntDef(GetLocaleStr(DefaultLCID, LOCALE_ITLZERO, '0', Buffer), 0) = 0 then
    begin
      StrCopy(ShortTimeFormat, 'h:mm');
      StrCopy(LongTimeFormat, 'h:mm:ss');
    end
  else
    begin
      StrCopy(ShortTimeFormat, 'hh:mm');
      StrCopy(LongTimeFormat, 'hh:mm:ss');
    end;
  if SysStrToIntDef(GetLocaleStr(DefaultLCID, LOCALE_ITIME, '0', Buffer), 0) = 0 then
    TimePostfix := ' AMPM';
  StrCat(ShortTimeFormat, TimePostfix);
  StrCat(LongTimeFormat, TimePostfix);
end;

function SysGetModuleName(var Address: Pointer; Buffer: PChar; BufSize: Longint): PChar;
var
  MemInfo: TMemoryBasicInformation;
  ModName: array[0..Max_Path] of Char;
begin
  VirtualQuery(Address, MemInfo, SizeOf(MemInfo));
  if (MemInfo.State <> mem_Commit) or
     (GetModuleFilename(THandle(MemInfo.AllocationBase), ModName, SizeOf(ModName)) = 0) then
    begin
      GetModuleFileName(HInstance, ModName, SizeOf(ModName));
      if Assigned(Address) then
        Dec(PChar(Address), $1000);
    end
  else
    Dec(PChar(Address), Longint(MemInfo.AllocationBase));
  StrLCopy(Buffer, StrRScan(ModName, '\') + 1, BufSize - 1);
  Result := Buffer;
end;

procedure SysDisplayConsoleError(PopupErrors: Boolean; Title, Msg: PChar);
var
  Count: Longint;
begin
  SysFileWrite(SysFileStdOut, Msg^, StrLen(Msg), Count);
end;

procedure SysDisplayGUIError(Title, Msg: PChar);
begin
  MessageBox(0, Msg, Title, MB_OK or MB_IconStop or MB_TaskModal);
end;

procedure SysBeep;
begin
  MessageBeep(0);
end;

procedure SysBeepEx(Freq,Dur: Longint);
begin
  Windows.Beep(Freq, Dur);
end;

function SysGetVolumeLabel(Drive: Char): ShortString;
const
  Root: Array[0..4] of char = 'C:\'#0;
var
  VolLabel: Array[0..256] of char;
  MaxLength: Longint;
  FSFlags: Longint;
begin
  Root[0] := Drive;
  if GetVolumeInformation(Root, VolLabel, Sizeof(VolLabel),
    nil, MaxLength, FSFlags, nil, 0) then
    Result := StrPas(VolLabel)
  else
    Result := '';
end;

function SysSetVolumeLabel(Drive: Char; _Label: ShortString): Boolean;
const
  Root: Array[0..4] of char = 'C:\'#0;
begin
  Root[0] := Drive;
  _Label[Length(_Label)+1] := #0;
  Result := SetVolumeLabel(Root, PChar(@_Label[1]));
end;

function SysGetForegroundProcessId: Longint;
var
  WHandle: Longint;
  ThreadID: Longint;
begin
  WHandle := GetForegroundWindow;
  Result := GetWindowThreadProcessId(WHandle, @ThreadID);
end;

function SysGetBootDrive: Char;
begin
  Result := 'C';
end;

function SysGetDriveType(Drive: Char): TDriveType;
const
  Root: Array[0..4] of char = 'C:\'#0;
var
  FSName: Array[0..255] of char;
  MaxLength: Longint;
  FSFlags: Longint;
begin
  Root[0] := Drive;
  Result := dtInvalid;
  if GetVolumeInformation(Root, nil, 0, nil, MaxLength, FSFlags, FSName, sizeof(FSName)) then
    begin
      if StrLComp(FSName, 'FAT', 3) = 0 then
        Result := dtHDFAT
      else if StrComp(FSName, 'HPFS') = 0 then
        Result := dtHDHPFS
      else if StrComp(FSName, 'NTFS') = 0 then
        Result := dtHDNTFS
      else if StrLComp(FSName, 'CD', 2) = 0 then
        Result := dtCDROM
      else if StrComp(FSName, 'LAN') = 0 then
        Result := dtLan
      else if StrComp(FSName, 'NOVELL') = 0 then
        Result := dtNovellNet;
    end;

  if Result = dtInvalid then
    case GetDriveType(Root) of
      Drive_Fixed     : Result := dtHDFAT;
      Drive_Removable : Result := dtFloppy;
      Drive_CDRom     : Result := dtCDROM;
      Drive_Remote    : Result := dtLAN;
      0, 1            : Result := dtInvalid;
    else                Result := dtUnknown;
    end;
end;

function SysGetVideoModeInfo( Var Cols, Rows, Colours : Word ): Boolean;
var
  Buffer: TConsoleScreenBufferInfo;
begin
  SysTVInitCursor;
  GetConsoleScreenBufferInfo(SysConOut, Buffer);

  Cols := Buffer.dwSize.x;
  Rows := Buffer.dwSize.y;
  Colours := 16; //Buffer.wAttributes;
end;

function SysGetVisibleLines( var Top, Bottom: Longint ): Boolean;
var
  Buffer: TConsoleScreenBufferInfo;
begin
  SysTVInitCursor;
  GetConsoleScreenBufferInfo(SysConOut, Buffer);
  Top := Buffer.srwindow.top+1;
  Bottom := Buffer.srwindow.bottom+1;
  Result := True;
end;

function SysSetVideoMode( Cols, Rows: Word ): Boolean;
var
  Size: TCoord;
  R: TSmallRect;
begin
  SysTVInitCursor;
  Size.X := Cols;
  Size.Y := Rows;
  Result := SetConsoleScreenBufferSize(SysConOut, Size);
  R.Left   := 0;
  R.Top    := 0;
  R.Right  := Size.X - 1;
  R.Bottom := Size.Y - 1;
  Result := SetConsoleWindowInfo(SysConOut, True, R);
end;

function SemCreateEvent(_Name: pChar; _Shared, _State: Boolean): TSemHandle;
var
  Security: TSecurityAttributes;
begin
  if _Shared then
    begin
      with Security do
        begin
          nLength := Sizeof(Security);
          lpSecurityDescriptor := nil;
          bInheritHandle := True;
        end;
      Result := CreateEvent(@Security, False, _State, _Name);
    end
  else
    Result := CreateEvent(nil, False, _State, _Name);
end;

function SemAccessEvent(_Name: PChar): TSemHandle;
begin
  Result := OpenEvent( Event_all_access, False, _Name);
  if Result = 0 then
    Result := -1;
end;

function SemPostEvent(_Handle: TSemhandle): Boolean;
begin
  Result := SetEvent(_Handle);
end;

function SemWaitEvent(_Handle: TSemHandle; _TimeOut: Longint): Boolean;
begin
  Result := WaitForSingleObject(_Handle, _TimeOut) = WAIT_OBJECT_0;
end;

function SemCreateMutex(_Name: PChar; _Shared, _State: Boolean): TSemHandle;
var
  Security: TSecurityAttributes;
begin
  if _Shared then
    begin
      with Security do
        begin
          nLength := Sizeof(Security);
          lpSecurityDescriptor := nil;
          bInheritHandle := True;
        end;
      Result := CreateMutex(@Security, _State, _Name);
    end
  else
    // Non-shared mutex does not require security descriptor
    Result := CreateMutex(nil, _State, _Name);
end;

function SemRequestMutex(_Handle: TSemHandle; _TimeOut: Longint): Boolean;
begin
  Result := WaitForSingleObject(_Handle, _TimeOut) = WAIT_OBJECT_0;
end;

function SemAccessMutex(_Name: PChar): TSemHandle;
begin
  Result := OpenMutex( mutex_all_access, False, _Name);
  if Result = 0 then
    Result := -1;
end;

function SemReleaseMutex(_Handle: TSemHandle): Boolean;
begin
  Result := ReleaseMutex( _Handle );
end;

procedure SemCloseEvent(_Handle: TSemHandle);
begin
  CloseHandle(_Handle);
end;

procedure SemCloseMutex(_Handle: TSemHandle);
begin
  CloseHandle(_Handle);
end;

function SysMemInfo(_Base: Pointer; _Size: Longint; var _Flags: Longint): Boolean;
var
  Buffer: TMemoryBasicInformation;
begin
  Result := VirtualQuery(_Base, Buffer, Sizeof(Buffer)) = Sizeof(Buffer);
  if Result then
    with Buffer do
     begin
       _Flags := 0;
       if Protect and (Page_ReadOnly or Page_ReadWrite or Page_Execute_Read) <> 0 then
         _Flags := _Flags or sysmem_Read or sysmem_Execute;
       if Protect and (Page_WriteCopy or Page_ReadWrite) <> 0 then
         _Flags := _Flags or sysmem_Write;
       if Protect and (Page_Execute or Page_Execute_Read or Page_Execute_ReadWrite) <> 0 then
         _Flags := _Flags or sysmem_Execute;
       if Protect and Page_Guard <> 0 then
         _Flags := _Flags or sysmem_Guard;
     end;
end;

function SysSetMemProtection(_Base: Pointer; _Size: Longint; _Flags: Longint): Boolean;
var
  Flags: Longint;
  Buffer: TMemoryBasicInformation;
begin
  VirtualQuery(_Base, Buffer, Sizeof(Buffer));
  if _Flags and sysmem_Execute <> 0 then
    if _Flags and sysmem_Read <> 0 then
      if _Flags and sysmem_Write <> 0 then
        Flags := page_Execute_ReadWrite
      else
        Flags := page_Execute_Read
    else
      if _Flags and sysmem_Write <> 0 then
        Flags := page_Execute_WriteCopy
      else
        Flags := page_Execute
  else
    if _Flags and sysmem_Read <> 0 then
      if _Flags and sysmem_Write <> 0 then
        Flags := page_ReadWrite
      else
        Flags := page_ReadOnly
    else
      if _Flags and sysmem_Write <> 0 then
        Flags := page_WriteCopy
      else
        Flags := page_NoAccess;
  Result := VirtualProtect(_Base, _Size, Flags, @Buffer);
end;

procedure SysMessageBox(_Msg, _Title: PChar; _Error: Boolean);
var
  Flag: Longint;
begin
  if _Error then
    Flag := mb_IconError
  else
    Flag := mb_IconInformation;
  MessageBox( 0, _Msg, _Title, Flag or mb_ApplModal);
end;

function SysClipCanPaste: Boolean;
var
  IsClipboardFormatAvailable: function(Format: UInt): Bool stdcall;
begin
  @IsClipboardFormatAvailable := QueryProcAddr('IsClipboardFormatAvailable', False);
  if Assigned(IsClipboardFormatAvailable) then
    Result := IsClipboardFormatAvailable(cf_Text)
  else
    Result := False;
end;

function SysClipCopy(P: PChar; Size: Longint): Boolean;
var
  Q: pChar;
  MemHandle: HGlobal;
  OpenClipboard: function(Wnd: hWnd): Bool stdcall;
  EmptyClipboard: function: Bool stdcall;
  CloseClipboard: function: Bool stdcall;
  SetClipboardData: function(Format: UInt; Mem: THandle): THandle stdcall;
begin
  Result := False;
  @OpenClipboard := QueryProcAddr('OpenClipboard', False);
  @EmptyClipboard := QueryProcAddr('EmptyClipboard', False);
  @CloseClipboard := QueryProcAddr('CloseClipboard', False);
  @SetClipboardData := QueryProcAddr('SetClipboardData', False);
  if Assigned(OpenClipboard) and Assigned(EmptyClipboard) and
    Assigned(CloseClipboard) and Assigned(SetClipboardData) then
  begin
    // Open clipboard
    if OpenClipboard(0) then
    begin
      EmptyClipboard;
      // Allocate a shared block of memory
      MemHandle := GlobalAlloc(gmem_Moveable or gmem_DDEShare, Size+1);
      Q := GlobalLock(MemHandle);
      // Copy clipboard data across and translate to ANSI charset
      Result := OemToCharBuff(P, Q, Size);
      Q[Size]:=#0;
      GlobalUnlock(MemHandle);
      // Insert data into clipboard
      if Result then
        Result := SetClipboardData(cf_Text, MemHandle) <> 0;
      // Do not free memory: Windows does this!
      // GlobalFree(MemHandle);
    end;
    CloseClipboard;
  end;
end;

function SysClipPaste(var Size: Integer): Pointer;
var
  P: Pointer;
  MemHandle: HGlobal;
  OpenClipboard: function(Wnd: hWnd): Bool stdcall;
  CloseClipboard: function: Bool stdcall;
  GetClipboardData: function(Format: UInt): THandle stdcall;
begin
  Result := nil;
  @OpenClipboard := QueryProcAddr('OpenClipboard', False);
  @CloseClipboard := QueryProcAddr('CloseClipboard', False);
  @GetClipboardData := QueryProcAddr('GetClipboardData', False);
  if Assigned(OpenClipboard) and Assigned(CloseClipboard)
    and Assigned(GetClipboardData) then
  begin
    if OpenClipboard(0) then
    begin
      MemHandle := GetClipboardData(cf_Text);
      P := GlobalLock(MemHandle);
      if Assigned(P) then
      begin
        Size := StrLen(P) + 1;
        GetMem(Result, Size);
        // Copy clipboard data across and translate to OEM charset
        CharToOemBuff(P, Result, Size);
      end;
      GlobalUnlock(MemHandle);
      CloseClipBoard;
    end;
  end;
end;

// Pharlap's TNT Embedded System support

function _malloc(Size: Longint): Pointer; cdecl; orgname;
begin
  GetMem(Result, Size);
end;

procedure _free(P: Pointer); cdecl; orgname;
begin
  FreeMem(P);
end;

// Retrieve various system settings, bitmapped:
// 0: Enhanced keyboard installed

function SysGetSystemSettings: Longint;
var
  KbdFlag: Longint;
begin
  Result := 0;
  KbdFlag := GetKeyboardType(0);
  if KbdFlag in [2, 4] then
    Result := Result OR 1;
end;