common.pas

雷神之锤2(Quake2)Delphi源码

  rd_target: Integer;
  rd_buffer: PChar;
  rd_buffersize: Integer;

var
  rd_flush: rd_flush_proc;

procedure Com_BeginRedirect(target: Integer; buffer: PChar; buffersize: Integer; flush: rd_flush_proc);
begin
  if (target = 0) or (buffer = nil) or (buffersize = 0) or (@flush = nil) then
    Exit;
  rd_target := target;
  rd_buffer := buffer;
  rd_buffersize := buffersize;
  rd_flush := flush;

  rd_buffer^ := #0;
end;

procedure Com_EndRedirect;
begin
  rd_flush(rd_target, rd_buffer);

  rd_target := 0;
  rd_buffer := nil;
  rd_buffersize := 0;
  rd_flush := nil;
end;


(*
=============
Com_Printf

Both client and server can use this, and it will output
to the apropriate place.
=============
*)
procedure Com_Printf(fmt: PChar; args: array of const);
var
  msg: array [0..MAXPRINTMSG-1] of Char;
  name: array [0..MAX_QPATH-1] of Char;
begin
  DelphiStrFmt(msg, fmt, args);

  if (rd_target <> 0) then
  begin
    if ((StrLen(msg) + StrLen(rd_buffer)) > Cardinal(rd_buffersize - 1)) then
    begin
      rd_flush(rd_target, rd_buffer);
      rd_buffer^ := #0;
   end;
    StrCat(rd_buffer, msg);
    Exit;
  end;

  Con_Print(msg);

  // also echo to debugging console
  Sys_ConsoleOutput(msg);

  // logfile
  if (logfile_active <> nil) and (logfile_active.value <> 0) then
  begin
    if (logfile = 0) then
    begin
      Com_sprintf(name, SizeOf(name), '%s/qconsole.log', [FS_Gamedir]);


      if (logfile_active.value > 2) then begin
        logfile := FileOpen(name, fmOpenReadWrite);
        FileSeek(logfile, 0, 2);
      end
      else
      begin
        DeleteFile(name);
        logfile := FileCreate(name, fmOpenReadWrite);
      end;

      //Clootie: need to clean up on error
      if logfile = -1 then
      begin
        logfile := 0;
      end;
    end;

    if (logfile <> 0) then
      FileWrite(logfile, msg, strlen(msg));
    if (logfile_active.value > 1) then;
      //Flush(logfile^);          // force it to save every time
  end;
end;

// Overloaded version without parameters
procedure Com_Printf(fmt: PChar);
begin
 Com_Printf(fmt, []);
end;


(*
================
Com_DPrintf

A Com_Printf that only shows up if the "developer" cvar is set
================
*)
procedure Com_DPrintf(fmt: PChar; args: array of const);
var
  msg: array [0..MAXPRINTMSG-1] of Char;
begin
  if (developer = nil) or (developer.value = 0) then
    Exit;			// don't confuse non-developers with techie stuff...

  DelphiStrFmt(msg, fmt, args);

  Com_Printf('%s', [msg]);
end;

// Overloaded version without parameters
procedure Com_DPrintf(fmt: PChar);
begin
 Com_DPrintf(fmt, []);
end;

(*
=============
Com_Error

Both client and server can use this, and it will
do the apropriate things.
=============
*)
procedure Com_Error(code: Integer; fmt: PChar; args: array of const);
{$IFDEF COMPILER6_UP}{$WRITEABLECONST ON}{$ENDIF}
const
  msg: array [0..MAXPRINTMSG-1] of Char = #0;
  recursive: qboolean = False;
{$IFDEF COMPILER6_UP}{$WRITEABLECONST OFF}{$ENDIF}
begin
  if (recursive) then
    Sys_Error('recursive error after: %s', [msg]);
  recursive := True;

  DelphiStrFmt(msg, fmt, args);

  if (code = ERR_DISCONNECT) then
  begin
    CL_Drop;
    recursive := False;
    raise ELongJump.Create('longjmp'); //Clootie: instead of "longjmp (abortframe, -1);"
  end
  else if (code = ERR_DROP) then
  begin
    Com_Printf('********************'#10'ERROR: %s'#10'********************'#10, [msg]);
    SV_Shutdown(va('Server crashed: %s'#10, [msg]), False);
    CL_Drop;
    recursive := False;
    raise ELongJump.Create('longjmp'); //Clootie: instead of "longjmp (abortframe, -1);"
  end
  else
  begin
    SV_Shutdown(va('Server fatal crashed: %s'#10, [msg]), False);
    CL_Shutdown;
  end;

  if (logfile <> 0) then
  begin
    FileClose(logfile);
    logfile := 0;
  end;

  Sys_Error('%s', [msg]);
end;

// Overloaded version without parameters
procedure Com_Error(code: Integer; fmt: PChar);
begin
  Com_Error(code, fmt, []);
end;

(*
=============
Com_Quit

Both client and server can use this, and it will
do the apropriate things.
=============
*)
procedure Com_Quit;
begin
  SV_Shutdown('Server quit'#10, False);
  CL_Shutdown;

  if (logfile <> 0) then
  begin
    FileClose(logfile);
    logfile := 0;
  end;

  Sys_Quit;
end;


(*
==================
Com_ServerState
==================
*)
function Com_ServerState: Integer;
begin
  Result:= server_state;
end;

(*
==================
Com_SetServerState
==================
*)
procedure Com_SetServerState(state: Integer);
begin
  server_state := state;
end;


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

			MESSAGE IO FUNCTIONS

Handles byte ordering and avoids alignment errors
==============================================================================
*)

//
// writing functions
//

procedure MSG_WriteChar(var sb: sizebuf_t; c: ShortInt);
var
  buf: PByteArray;
begin
{$IFDEF PARANOID}
  if (c < -128) or (c > 127) then
    Com_Error(ERR_FATAL, 'MSG_WriteChar: range error', []);
{$ENDIF}

  buf := SZ_GetSpace(sb, 1);
  buf[0] := c;
end;

procedure MSG_WriteByte(var sb: sizebuf_t; c: Integer);
var
  buf: PByteArray;
begin
{$IFDEF PARANOID}
  if (c < 0) or (c > 255) then
    Com_Error(ERR_FATAL, 'MSG_WriteByte: range error', []);
{$ENDIF}

  buf := SZ_GetSpace(sb, 1);
  buf[0] := Byte(c);
end;

procedure MSG_WriteShort(var sb: sizebuf_t; c: Integer);
var
  buf: PByteArray;
begin
{$IFDEF PARANOID}
  if (c < SmallInt($8000)) or (c > SmallInt($7fff)) then
    Com_Error(ERR_FATAL, 'MSG_WriteShort: range error', []);
{$ENDIF}

  buf := SZ_GetSpace(sb, 2);
  buf[0] := c and $ff;
  buf[1] := Byte(c shr 8);
end;

procedure MSG_WriteLong(var sb: sizebuf_t; c: Integer);
var
  buf: PByteArray;
begin
  buf := SZ_GetSpace (sb, 4);
  buf[0] := c and $ff;
  buf[1] := (c shr 8) and $ff;
  buf[2] := (c shr 16) and $ff;
  buf[3] := c shr 24;
end;

procedure MSG_WriteFloat(var sb: sizebuf_t; f: Single);
type
  dat_ = packed record
    case Boolean of
      True:  (f: Single;);
      False: (l: Integer;)
  end;
var
  dat: dat_;
begin
  dat.f := f;
  dat.l := LittleLong(dat.l);

  SZ_Write(sb, @dat.l, 4);
end;

procedure MSG_WriteString(var sb: sizebuf_t; s: PChar);
begin
  if (s = nil) then
    SZ_Write(sb, PChar(''), 1)
  else
    SZ_Write(sb, s, StrLen(s)+1);
end;

procedure MSG_WriteCoord(var sb: sizebuf_t; f: Single);
begin
  MSG_WriteShort(sb, Trunc(f*8));
end;

procedure MSG_WritePos(var sb: sizebuf_t; const pos: vec3_t);
begin
  MSG_WriteShort(sb, Trunc(pos[0]*8));
  MSG_WriteShort(sb, Trunc(pos[1]*8));
  MSG_WriteShort(sb, Trunc(pos[2]*8));
end;

procedure MSG_WriteAngle(var sb: sizebuf_t; f: Single);
begin
  MSG_WriteByte(sb, Trunc(f*256/360) and 255);
end;

procedure MSG_WriteAngle16(var sb: sizebuf_t; f: Single);
begin
  MSG_WriteShort(sb, ANGLE2SHORT(f));
end;

procedure MSG_WriteDeltaUsercmd(var buf: sizebuf_t; const from: usercmd_s; const cmd: usercmd_s);
var
  bits: Integer;
begin
//
// send the movement message
//
    bits := 0;
    if (cmd.angles[0] <> from.angles[0]) then
      bits := bits or CM_ANGLE1;
    if (cmd.angles[1] <> from.angles[1]) then
      bits := bits or CM_ANGLE2;
    if (cmd.angles[2] <> from.angles[2]) then
      bits := bits or CM_ANGLE3;
    if (cmd.forwardmove <> from.forwardmove) then
      bits := bits or CM_FORWARD;
    if (cmd.sidemove <> from.sidemove) then
      bits := bits or CM_SIDE;
    if (cmd.upmove <> from.upmove) then
      bits := bits or CM_UP;
    if (cmd.buttons <> from.buttons) then
      bits := bits or CM_BUTTONS;
    if (cmd.impulse <> from.impulse) then
      bits := bits or CM_IMPULSE;

  MSG_WriteByte(buf, bits);

    if (bits and CM_ANGLE1) <> 0 then
      MSG_WriteShort(buf, cmd.angles[0]);
    if (bits and CM_ANGLE2) <> 0 then
      MSG_WriteShort (buf, cmd.angles[1]);
    if (bits and CM_ANGLE3) <> 0 then
      MSG_WriteShort (buf, cmd.angles[2]);

    if (bits and CM_FORWARD) <> 0 then
      MSG_WriteShort (buf, cmd.forwardmove);
    if (bits and CM_SIDE) <> 0 then
      MSG_WriteShort (buf, cmd.sidemove);
    if (bits and CM_UP) <> 0 then
      MSG_WriteShort (buf, cmd.upmove);

    if (bits and CM_BUTTONS) <> 0 then
      MSG_WriteByte (buf, cmd.buttons);
    if (bits and CM_IMPULSE) <> 0 then
      MSG_WriteByte (buf, cmd.impulse);

  MSG_WriteByte(buf, cmd.msec);
    MSG_WriteByte(buf, cmd.lightlevel);
end;

procedure MSG_WriteDir(var sb: sizebuf_t; dir: vec3_p);
var
  i, best: Integer;
  d, bestd: Single;
begin
  if (dir = nil) then 
  begin
    MSG_WriteByte(sb, 0);
    Exit;
  end;

  bestd := 0;
  best := 0;
  for i := 0 to NUMVERTEXNORMALS - 1 do
  begin
    d := DotProduct(dir^, bytedirs[i]);
    if (d > bestd) then
    begin
      bestd := d;
      best := i;
    end;
  end;
  MSG_WriteByte(sb, best);
end;

procedure MSG_ReadDir(var sb: sizebuf_t; var dir: vec3_t);
// void MSG_ReadDir (sizebuf_t *sb, vec3_t dir)
var
  b: Integer;
begin
  b := MSG_ReadByte(sb);
  if (b >= NUMVERTEXNORMALS) then
    Com_Error(ERR_DROP, 'MSF_ReadDir: out of range', []);
  VectorCopy(bytedirs[b], dir);
end;

(*
==================
MSG_WriteDeltaEntity

Writes part of a packetentities message.
Can delta from either a baseline or a previous packet_entity
==================
*)
procedure MSG_WriteDeltaEntity(const from, to_: entity_state_s; var msg: sizebuf_t; force, newentity: qboolean);
var
  bits: Integer;
begin
  if (to_.number = 0) then
    Com_Error(ERR_FATAL, 'Unset entity number', []);
  if (to_.number >= MAX_EDICTS) then
    Com_Error(ERR_FATAL, 'Entity number >= MAX_EDICTS', []);

// send an update
  bits := 0;

  if (to_.number >= 256) then
    bits := bits or U_NUMBER16;		// number8 is implicit otherwise

  if (to_.origin[0] <> from.origin[0]) then
    bits := bits or U_ORIGIN1;
  if (to_.origin[1] <> from.origin[1]) then
    bits := bits or U_ORIGIN2;
  if (to_.origin[2] <> from.origin[2]) then
    bits := bits or U_ORIGIN3;

  if (to_.angles[0] <> from.angles[0]) then
    bits := bits or U_ANGLE1;
  if (to_.angles[1] <> from.angles[1]) then
    bits := bits or U_ANGLE2;
  if (to_.angles[2] <> from.angles[2]) then
    bits := bits or U_ANGLE3;

  if (to_.skinnum <> from.skinnum) then
  begin
    if (Cardinal(to_.skinnum) < 256) then
      bits := bits or U_SKIN8
    else if (Cardinal(to_.skinnum) < $10000) then
      bits := bits or U_SKIN16
    else
      bits := bits or (U_SKIN8 or U_SKIN16);
  end;

  if (to_.frame <> from.frame) then
  begin
    if (to_.frame < 256) then
      bits := bits or U_FRAME8
    else
      bits := bits or U_FRAME16;
  end;

  if (to_.effects <> from.effects) then
  begin
    if (to_.effects < 256) then
      bits := bits or U_EFFECTS8
    else if (to_.effects < $8000) then
      bits := bits or U_EFFECTS16
    else
      bits := bits or U_EFFECTS8 or U_EFFECTS16;
  end;

  if (to_.renderfx <> from.renderfx) then
  begin
    if (to_.renderfx < 256) then
      bits := bits or U_RENDERFX8
    else if (to_.renderfx < $8000) then
      bits := bits or U_RENDERFX16
    else
      bits := bits or U_RENDERFX8 or U_RENDERFX16;
  end;
	
  if (to_.solid <> from.solid) then
    bits := bits or U_SOLID;

  // event is not delta compressed, just 0 compressed
  if (to_.event <> EV_NONE) then
    bits := bits or U_EVENT;

  if (to_.modelindex <> from.modelindex) then
    bits := bits or U_MODEL;
  if (to_.modelindex2 <> from.modelindex2) then
    bits := bits or U_MODEL2;
  if (to_.modelindex3 <> from.modelindex3) then
    bits := bits or U_MODEL3;
  if (to_.modelindex4 <> from.modelindex4) then
    bits := bits or U_MODEL4;

  if (to_.sound <> from.sound) then
    bits := bits or U_SOUND;

  if newentity  or ((to_.renderfx and RF_BEAM) <> 0) then
    bits := bits or U_OLDORIGIN;

  //
  // write the message
  //
  if (bits = 0) and not force then
    Exit;		// nothing to send!

  //----------

  if (bits and $ff000000) <> 0 then
    bits := bits or U_MOREBITS3 or U_MOREBITS2 or U_MOREBITS1
  else if (bits and $00ff0000) <> 0 then
    bits := bits or U_MOREBITS2 or U_MOREBITS1
  else if (bits and $0000ff00) <> 0 then
    bits := bits or U_MOREBITS1;

  MSG_WriteByte(msg, bits and 255);

  if (bits and $ff000000) <> 0 then
  begin
    MSG_WriteByte(msg, (bits shr 8) and 255);
    MSG_WriteByte(msg, (bits shr 16) and 255);
    MSG_WriteByte(msg, (bits shr 24) and 255);