q_shared.pas

delphi编的不错的贪吃蛇

  //
  src := path;
  inc(src, strlen(path) - 1);

  while (src^ <> '/') and (src <> path) do
  begin
    if (src^ = '.') then
      exit;                             // it has an extension
    dec(src);
  end;

  strcat(path, extension);
end;

(*
============================================================================

     BYTE ORDER FUNCTIONS

============================================================================
*)

var
  bigendien: qboolean;                  // NOTE SPELLING!!!!
  // can't just use function pointers, or dll linkage can
  // mess up when qcommon is included in multiple places
  _BigShort: function(L: SmallInt): SmallInt;
  _LittleShort: function(L: SmallInt): SmallInt;
  _BigLong: function(L: LongInt): LongInt;
  _LittleLong: function(L: LongInt): LongInt;
  _BigFloat: function(L: Single): Single;
  _LittleFloat: function(L: Single): Single;

function BigShort(L: SmallInt): SmallInt;
begin
  Result := _BigShort(L);
end;

function LittleShort(L: SmallInt): SmallInt;
begin
  Result := _LittleShort(L);
end;

function BigLong(L: LongInt): LongInt;
begin
  Result := _BigLong(L);
end;

function LittleLong(L: LongInt): LongInt;
begin
  Result := _LittleLong(L);
end;

function BigFloat(L: Single): Single;
begin
  Result := _BigFloat(L);
end;

function LittleFloat(L: Single): Single;
begin
  Result := _LittleFloat(L);
end;

function ShortSwap(L: SmallInt): SmallInt;
var
  b1, b2: Byte;
begin
  b1 := L and 255;
  b2 := (L shr 8) and 255;
  result := (b1 shl 8) + b2;
end;

function ShortNoSwap(L: SmallInt): SmallInt;
begin
  result := L
end;

function LongSwap(L: LongInt): LongInt;
var
  b1, b2, b3, b4: Byte;
begin
  b1 := L and 255;
  b2 := (L shr 8) and 255;
  b3 := (L shr 16) and 255;
  b4 := (L shr 24) and 255;
  result := (LongInt(b1) shl 24) + (LongInt(b2) shl 16) + (LongInt(b3) shl 8) + b4;
end;

function LongNoSwap(L: LongInt): LongInt;
begin
  result := L
end;

function FloatSwap(f: Single): Single;
type
  ba = array[0..3] of byte;
var
  dat1, dat2: ^ba;
begin
  dat1 := Pointer(@f);
  dat2 := Pointer(@result);
  dat2[0] := dat1[3];
  dat2[1] := dat1[2];
  dat2[2] := dat1[1];
  dat2[3] := dat1[0];
end;

function FloatNoSwap(f: Single): Single;
begin
  Result := f;
end;

(*
================
Swap_Init
================
*)

procedure Swap_Init;
var
  swaptest: array[0..1] of byte;
begin
  swaptest[0] := 1;
  swaptest[1] := 0;

  // set the byte swapping variables in a portable manner
  if PSmallInt(@SwapTest)^ = 1 then
  begin
    bigendien := false;
    @_BigShort := @ShortSwap;
    @_LittleShort := @ShortNoSwap;
    @_BigLong := @LongSwap;
    @_LittleLong := @LongNoSwap;
    @_BigFloat := @FloatSwap;
    @_LittleFloat := @FloatNoSwap;
  end
  else
  begin
    bigendien := true;
    @_BigShort := @ShortNoSwap;
    @_LittleShort := @ShortSwap;
    @_BigLong := @LongNoSwap;
    @_LittleLong := @LongSwap;
    @_BigFloat := @FloatNoSwap;
    @_LittleFloat := @FloatSwap;
  end;
end;

(*
============
va

does a varargs printf into a temp buffer, so I don't need to have
varargs versions of all text functions.
FIXME: make this buffer size safe someday
============
*)
{static}
var
  _string: array[0..1024 - 1] of char;

function va(format: PChar; const Args: array of const): PChar;
begin
  DelphiStrFmt(_string, format, args);
  Result := @_string;
end;

var
  com_token: array[0..MAX_TOKEN_CHARS - 1] of Char;

  (*
  ==============
  COM_Parse

  Parse a token out of a string
  ==============
  *)

function COM_Parse(var data_p: PChar): PChar; // CAK - WARNING!!!! WAS ^PChar
// data is an in/out parm, returns a parsed out token
var
  data: PChar;
  c: Char;
  len: Integer;
label
  skipwhite;
begin
  data := data_p;
  len := 0;
  com_token[0] := #0;

  if (data = nil) then
  begin
    data_p := nil;
    Result := '';
    exit;
  end;

  // skip whitespace
  skipwhite:
  c := data^;
  while c <= ' ' do
  begin
    if c = #0 then
    begin
      data_p := nil;
      Result := '';
      exit;
    end;
    inc(data);
    c := data^;
  end;

  // skip // comments
  if (c = '/') and (data[1] = '/') then
  begin
    while (data^ <> #0) and (data^ <> #13) and (data^ <> #10) do
    begin                               // CAK - '\n' can be #13 or #10
      inc(data);
    end;
    goto skipwhite;
  end;

  // handle quoted strings specially
  if (c = '"') then
  begin
    inc(data);
    while true do
    begin
      c := data^;
      inc(data);
      if (c = '"') or (c = #0) then
      begin
        com_token[len] := #0;
        data_p := data;
        result := com_token;
        exit;
      end;
      // 10-Jun-2002 Juha: NOTE, original quake2 has this bug as well. If you
      // send exactly MAX_TOKEN_CHARS length connect string, it will crash the
      // server. We might want to make this read "if (len<MAX_TOKEN_CHARS-1)".
      if (len < MAX_TOKEN_CHARS) then
      begin
        com_token[len] := c;
        inc(len);
      end;
    end;
  end;

  // parse a regular word
  repeat
    if len < MAX_TOKEN_CHARS then
    begin
      com_token[len] := c;
      inc(len);
    end;
    inc(data);
    c := data^;
  until c <= #32;

  if len = MAX_TOKEN_CHARS then
  begin
    Com_Printf('Token exceeded %i chars, discarded.'#10, [MAX_TOKEN_CHARS]);
    len := 0;
  end;
  com_token[len] := #0;

  data_p := data;
  result := com_token;
end;

(*
===============
Com_PageInMemory

===============
*)
var
  paged_total: Integer;                 // CAK - This variable is never initialised ANYWHERE
  // But as it's never used anywhere either, I guess
  // that doesn't matter. :-)
  // all it is used for is to ensure that one byte out
  // of every 4K pointed to by buffer is read, and
  // therefore in memory.

procedure Com_PageInMemory(buffer: PByte; size: Integer);
var
  i: Integer;
begin
  i := size - 1;
  while (i > 0) do
  begin
    paged_total := paged_total + PByteArray(buffer)[i];
    dec(i, 4096);
  end;
end;

(*
============================================================================

     LIBRARY REPLACEMENT FUNCTIONS

============================================================================
*)

// FIXME: replace all Q_stricmp with Q_strcasecmp

function Q_stricmp(s1, s2: PChar): Integer;
begin
  Result := strcmp(PChar(LowerCase(s1)), PChar(LowerCase(s2)));
end;

function Q_strncasecmp(s1, s2: PChar; n: integer): Integer;
var
  z1, z2: string;
begin
  z1 := s1;
  z2 := s2;
  z1 := lowercase(copy(z1, 1, n));
  z2 := lowercase(copy(z2, 1, n));
  if z1 = z2 then
    result := 0                         // strings are equal
  else
    result := -1;                       // strings not equal
end;

function Q_strcasecmp(s1, s2: PChar): Integer;
begin
  result := Q_strncasecmp(s1, s2, 99999);
end;

procedure Com_sprintf(dest: PChar; size: Integer; fmt: PChar; const Args: array of const);
var
  bigbuffer: array[0..$10000 - 1] of char;
  SLen: Integer;
begin
  DelphiStrFmt(bigbuffer, fmt, Args);
  SLen := StrLen(bigbuffer);
  move(bigbuffer, dest^, Min(size, SLen + 1));
  { Terminate string if needed }
  if SLen >= size then
    dest[size - 1] := #0;
end;

(*
=====================================================================

  INFO STRINGS

=====================================================================
*)

(*
===============
Info_ValueForKey

Searches the string for the given
key and returns the associated value, or an empty string.
===============
*)
var
  value: array[0..1, 0..511] of Char;   // use two buffers so compares
  valueindex: integer;                  // work without stomping on each other

function Info_ValueForKey(s, key: PChar): PChar;
var
  pkey: array[0..511] of Char;
  o: PChar;
begin
  valueindex := valueindex xor 1;
  if s^ = '\' then
    inc(s);
  while true do
  begin
    o := pkey;
    while (s^ <> '\') do
    begin
      if s^ = #0 then
      begin
        Result := '';
        exit;
      end;
      o^ := s^;
      inc(o);
      inc(s);
    end;
    o^ := #0;
    inc(s);

    o := value[valueindex];

    while (s^ <> '\') and (s^ <> #0) do
    begin
      if (s^ = #0) then
      begin
        result := '';
        exit;
      end;
      o^ := s^;
      inc(o);
      inc(s);
    end;
    o^ := #0;

    if (strcomp(key, pkey) = 0) then
    begin
      result := value[valueindex];
      exit;
    end;

    if s^ = #0 then
    begin
      result := '';
      exit;
    end;
    inc(s);
  end;
end;

procedure Info_RemoveKey(s, key: PChar);
var
  start: PChar;
  pkey, value: array[0..511] of Char;
  o: PChar;
begin
  if (pos('\', key) <> 0) then
  begin
    Com_Printf('Can''t use a key with a \'#13#10);
    exit;
  end;

  while true do
  begin
    start := s;
    if (s^ = '\') then
      inc(s);
    o := pkey;
    while s^ <> '\' do
    begin
      if s^ = #0 then
        exit;
      o^ := s^;
      inc(o);
      inc(s);
    end {while};
    o^ := #0;
    inc(s);

    o := value;

    while (s^ <> '\') and (s^ <> #0) do
    begin
      if s^ = #0 then
        exit;
      o^ := s^;
      inc(o);
      inc(s);
    end;
    o^ := #0;

    if strcomp(key, pkey) = 0 then
    begin
      strcopy(start, s);                // remove this part
      exit;
    end;

    if s^ = #0 then
      exit;
  end {while};
end;

(*
==================
Info_Validate

Some characters are illegal in info strings because they
can mess up the server's parsing
==================
*)

function Info_Validate(s: PChar