sys_win.pas

delphi编的不错的贪吃蛇

{----------------------------------------------------------------------------}
{                                                                            }
{ File(s): sys_win.c                                                         }
{                                                                            }
{ Initial conversion by : Softland ([e-mail])                  }
{ Initial conversion on : 07-Jan-2002                                        }
{                                                                            }
{ This File contains part of convertion of Quake2 source to ObjectPascal.    }
{ More information about this project can be found at:                       }
{ http://www.sulaco.co.za/quake2/                                            }
{                                                                            }
{ Copyright (C) 1997-2001 Id Software, Inc.                                  }
{                                                                            }
{ This program is free software; you can redistribute it and/or              }
{ modify it under the terms of the GNU General Public License                }
{ as published by the Free Software Foundation; either version 2             }
{ of the License, or (at your option) any later version.                     }
{                                                                            }
{ 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.                       }
{                                                                            }
{ See the GNU General Public License for more details.                       }
{                                                                            }
{----------------------------------------------------------------------------}
{ Updated on : 03-jun-2002                                                   }
{ Updated by : Juha Hartikainen ([e-mail])                        }
{ - Fixed uses clause                                                        }
{----------------------------------------------------------------------------}

unit sys_win;

interface

uses
  Windows,
  q_shared;

const
  MINIMUM_WIN_MEMORY = $0A00000;
  MAXIMUM_WIN_MEMORY = $1000000;
  MAX_NUM_ARGVS = 128;

var
  s_win95: qboolean;
  starttime: Integer;
  ActiveApp: Integer;
  Minimized: qboolean;
  hinput: THandle;
  houtput: THandle;
  sys_msg_time: Cardinal;
  sys_frame_time: Cardinal;
  qwclsemaphore: THandle;
  argc: Integer;
  argv: array[0..MAX_NUM_ARGVS - 1] of PChar;
  console_text: array[0..255] of Char;
  console_textlen: Integer;
  game_library: HINST;
  global_hInstance: HINST;

procedure Sys_Error(error: PChar; args: array of const);
procedure Sys_Quit;
function Sys_ScanForCD: PChar;
procedure Sys_CopyProtect;
procedure Sys_Init;
function Sys_ConsoleInput: PChar;
procedure Sys_ConsoleOutput(aString: PChar);
procedure Sys_SendKeyEvents;
function Sys_GetClipboardData: PChar;
procedure Sys_AppActivate;
procedure Sys_Unloadgame;
function Sys_GetGameAPI(parms: Pointer): Pointer;

procedure WinError;
procedure ParseCommandLine(lpCmdLine: LPSTR);
function WinMain(hInstance, hPrevInstance: HINST; lpCmdLine: LPSTR; nCmdShow: Integer): Integer; stdcall;

implementation

uses
  SysUtils,
  MMSystem,
  Math,
  Files,
  Common,
  cl_main,
  conproc,
  vid_dll,
  q_shwin;

var

  // Those are only used by Sys_ScanForCD.
  cddir: array[0..MAX_OSPATH - 1] of Char;
  done: qboolean;

procedure Sys_Error(error: PChar; args: array of const);
var
  text: string;
begin
  CL_Shutdown;
  Qcommon_Shutdown;

  // Report error.
  text := Format(error, args);
  MessageBox(0, PChar(text), 'Error', 0 { MB_OK});

  if qwclsemaphore <> 0 then
    CloseHandle(qwclsemaphore);
  DeinitConProc;

  Halt(1);
end;

procedure Sys_Quit;
begin
  timeEndPeriod(1);
  CL_Shutdown;
  Qcommon_Shutdown;
  CloseHandle(qwclsemaphore);
  if (dedicated <> nil) and (dedicated.value <> 0) then
    FreeConsole;
  DeinitConProc();

  Halt(0);
end;

procedure WinError;
var
  lpMsgBuf: PChar;
begin
  FormatMessage(
    FORMAT_MESSAGE_ALLOCATE_BUFFER or FORMAT_MESSAGE_FROM_SYSTEM,
    nil,
    GetLastError,
    (SUBLANG_DEFAULT shl 10) or LANG_NEUTRAL,
    PChar(@lpMsgBuf),
    0,
    nil);
  MessageBox(0, lpMsgBuf, 'GetLastError', MB_OK or MB_ICONINFORMATION);
  LocalFree(HLOCAL(lpMsgBuf));          // Frees the buffer allocated by FormatMessage.
end;

function Sys_ScanForCD: PChar;

{$IFNDEF DEMO}

var
  path: string;
  drive: string;

{$ENDIF}

begin

{$IFNDEF DEMO}

  // Don't re-check.
  if done then
  begin
    Result := cddir;
    Exit;
  end;

  // no abort/retry/fail errors
  SetErrorMode(SEM_FAILCRITICALERRORS);

  drive := 'c:\';
  done := True;

  // Start scanning for the CD-ROM drive on which "quake2.exe" exists.
  while drive[1] <= 'z' do
  begin
    path := drive + 'install\data';
    Move(PChar(path)^, cddir, Length(path));
    if FileExists(path + '\quake2.exe') then
      if GetDriveType(PChar(drive)) = DRIVE_CDROM then
      begin
        Result := cddir;
        Exit;
      end;
    Inc(drive[1]);
  end;

{$ENDIF}

  cddir[0] := #0;
  Result := nil;
end;

procedure Sys_CopyProtect;

{$IFNDEF DEMO}

var
  cddir: PChar;

{$ENDIF}

begin

{$IFNDEF DEMO}

  cddir := Sys_ScanForCD;
  if cddir^ = #0 then
    Com_Error(ERR_FATAL, 'You must have the Quake2 CD in the drive to play.');

{$ENDIF}

end;

procedure Sys_Init;
var
  vinfo: OSVERSIONINFO;
begin
  {

    // Mutex will fail if semaphore already exists.
    qwclsemaphore := CreateMutex(nil, False, 'qwcl');
    if qwclsemaphore = 0 then
      Sys_Error('QWCL is already running on this system', []);
    CloseHandle(qwclsemaphore);

    // Allocate a named semaphore on the client,
    // so that the front end can tell if it is alive.
    qwclsemaphore := CreateSemaphore(nil, 0, 1, 'qwcl');

  }

    // Juha: Needed for Delphi.
  Randomize;

  timeBeginPeriod(1);

  // Vhecking version information.
  vinfo.dwOSVersionInfoSize := SizeOf(vinfo);
  if not GetVersionEx(vinfo) then
    Sys_Error('Couldn''t get OS info', []);
  if vinfo.dwMajorVersion < 4 then
    Sys_Error('Quake2 requires windows version 4 or greater', []);
  if vinfo.dwPlatformId = VER_PLATFORM_WIN32s then
    Sys_Error('Quake2 doesn''t run on Win32s', [])
  else if vinfo.dwPlatformId = VER_PLATFORM_WIN32_WINDOWS then
    s_win95 := True;

  if dedicated.value <> 0 then
  begin
    if not AllocConsole then
      Sys_Error('Couldn''t create dedicated server console', []);
    hinput := GetStdHandle(STD_INPUT_HANDLE);
    houtput := GetStdHandle(STD_OUTPUT_HANDLE);
    InitConProc(argc, @argv[0]);
  end;
end;

function Sys_ConsoleInput: PChar;
var
  recs: array[0..1023] of INPUT_RECORD;
  dummy: Integer;
  ch, numread, numevents: Integer;
begin
  Result := nil;
  if (dedicated = nil) or (dedicated.value = 0) then
    Exit;

  while True do
  begin

    // End the loop, if there are no console input events.
    if not GetNumberOfConsoleInputEvents(hinput, Cardinal(numevents)) then
      Sys_Error('Error getting # of console events', []);
    if numevents <= 0 then
      Break;

    // Read console input.
    if not ReadConsoleInput(hinput, recs[0], 1, Cardinal(numread)) then
      Sys_Error('Error reading console input', []);
    if numread <> 1 then
      Sys_Error('Couldn''t read console input', []);

    // Process console input.
    if recs[0].EventType = KEY_EVENT then
      if not recs[0].Event.KeyEvent.bKeyDown then
      begin
        ch := Integer(recs[0].Event.KeyEvent.AsciiChar);
        case ch of
          13:                           // Pressed key = [Enter]
            begin
              WriteFile(houtput, #13#10, 2, Cardinal(dummy), nil);
              if console_textlen <> 0 then
              begin
                console_text[console_textlen] := #0;
                console_textlen := 0;
                Result := console_text;
                Exit;
              end;
            end;