{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
Author: Alexander Vaga
EMail: alexander_vaga@hotmail.com
Creation: May, 2002
Legal issues: Copyright (C) 2002 by Alexander Vaga
  Kyiv, Ukraine
  This software is provided 'as-is', without any express or
  implied warranty. In no event will the author be held liable
  for any damages arising from the use of this software.
  Permission is granted to anyone to use this software for any
  purpose, including commercial applications, and to alter it
  and redistribute it freely.
 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
unit Packet;
interface
uses Types,SysUtils,Math,StdCtrls,
  Windows,Winsock;
const OL : booLean = false;
function CreatePacket(ChID:byte; var SEQ:word) : PPack;
function PacketNew : PPack;
procedure PacketDelete(p:PPack);
procedure PacketAppend8(p : PPack; i : byte);
procedure PacketAppend16(p : PPack; i : word);
procedure PacketAppend32(p : PPack; i : longint);
procedure SetLengthPacket(p : PPack);
procedure TLVAppendStr(p : PPack; T:word;V:string);
function TLVReadStr(p : PPack; var V:string):word;
procedure TLVAppendWord(p : PPack; T:word;V:word);
procedure TLVAppendDWord(p : PPack; T:word;V:longint);
function TLVReadWord(p : PPack; var V:word):word;
function TLVReadDWord(p : PPack; var V:longint):word;
procedure TLVAppend(p : PPack; T:word;L:word;V:pointer);
procedure SNACAppend(p : PPack; FamilyID,SubTypeID:word);
function PacketRead8(p : PPack): byte;
function PacketRead16(p : PPack): word;
function PacketRead32(p : PPack): longint;
procedure PacketAdvance(p:PPack; i : integer);
procedure PacketAppendB_String(p:PPack; s:string);
procedure PacketAppendString(p:PPack; s:string);
procedure PacketAppendStringFE(p:PPack; s:string);
procedure PacketAppend(p:PPack; what:pointer; len:integer);
procedure PacketRead(p:PPack; Buf:pointer; length:integer);
function PacketReadString(p:PPack):string;
function PacketReadB_String(p:PPack):string;
procedure PacketBegin(p:PPack);
procedure PacketEnd(p:PPack);
procedure PacketGoto(p:PPack; i:integer);
function PacketPos(p:PPack):word;
function Swap(InWord:word):word;
function DSwap(InLong:longint):longint;assembler;
function Dim2Hex(what:pointer;len:integer):string;
function Dim2Str(what:pointer;len:integer):string;
procedure StrToIP(sIP:string; var aIP:IParray);
function IPtoStr(var aIP:IParray):string;
function UTC2LT(year,month,day,hour,min:integer) : TDateTime;
function Now2DateTime : TDateTime;
function SecsSince1970:longint;
function Get_my_IP: string;
function Calc_Pass(PassIN : string):string;
function s(i : longint) : string;
procedure M(Memo:TMemo; s:string);

implementation
function CreatePacket(ChID:byte; var SEQ:word) : PPack;
var p : PPack;
begin
  p := PacketNew;
  PacketAppend8(p, $2A);
  PacketAppend8(p, ChID);
  PacketAppend16(p, swap(SEQ)); inc(SEQ);
  PacketAppend16(p, 0); // length - must be filled
  Result := p;
end;
function PacketNew : PPack;
var p : PPack;
begin
  New(p);
  fillchar(p^,sizeof(Pack),0);
  p^.cursor :=0;
  p^.length :=0;
  PacketNew := p;
end;
procedure PacketDelete(p:PPack);
begin
  Dispose(p);
end;
procedure PacketAdvance(p:PPack; i : integer);
begin
  p^.cursor := p^.cursor+i;
  if p^.cursor > p^.length then
  p^.length := p^.cursor;
end;
procedure PacketAppend8(p : PPack; i : byte);
begin
  PBYTE(@(p^.data[p^.cursor]))^ := i;
  PacketAdvance(p,sizeof(byte));
end;
procedure PacketAppend16(p : PPack; i : word);
begin
  PWORD(@(p^.data[p^.cursor]))^ := i;
  PacketAdvance(p,sizeof(word));
end;
procedure PacketAppend32(p : PPack; i : longint);
begin
  PLONG(@(p^.data[p^.cursor]))^ := i;
  PacketAdvance(p,sizeof(longint));
end;
procedure SetLengthPacket(p : PPack);
begin
  PFLAP_HDR(@(p^.data))^.Len := swap(p^.length-sizeof(FLAP_HDR));
end;
procedure TLVAppendStr(p : PPack; T:word;V:string);
var i : integer;
begin
  PacketAppend16(p,swap(T)); // add TYPE
  PacketAppend16(p,swap(length(V))); // add LEN
  for i:=1 to Length(V) do  // add VALUE (variable)
  PacketAppend8(p,byte(V[i]));
end;
function TLVReadStr(p : PPack; var V:string):word;
var i,L : integer;
begin
  V:='';
  Result := swap(PacketRead16(p));
  L := swap(PacketRead16(p));
  for i:=1 to L do // add VALUE (variable)
  V:=V+char(PacketRead8(p));
end;

procedure TLVAppendWord(p : PPack; T:word;V:word);
begin
  PacketAppend16(p,swap(T)); // add TYPE
  PacketAppend16(p,swap(sizeof(word))); // add LEN
  PacketAppend16(p,swap(V)); // add VALUE
end;
function TLVReadWord(p : PPack; var V:word):word;
begin
  Result := swap(PacketRead16(p)); // get TYPE
  if swap(PacketRead16(p))<>0 then // xxxx LEN (word=2)
  V := swap(PacketRead16(p)); // get 16-VALUE
end;
procedure TLVAppendDWord(p : PPack; T:word;V:longint);
begin
  PacketAppend16(p,swap(T)); // add TYPE
  PacketAppend16(p,swap(sizeof(longint))); // add LEN
  PacketAppend32(p,dswap(V)); // add VALUE
end;
function TLVReadDWord(p : PPack; var V:longint):word;
begin
  Result := swap(PacketRead16(p)); // get TYPE
  if swap(PacketRead16(p))<>0 then // xxxx LEN (word=2)
  V := dswap(PacketRead32(p)); // get 32-VALUE
end;
procedure TLVAppend(p : PPack; T:word;L:word;V:pointer);
begin
  PacketAppend16(p,swap(T)); // add TYPE
  PacketAppend16(p,swap(L)); // add LEN
  PacketAppend(p,V,L); // add VALUE (variable)
end;
procedure SNACAppend(p : PPack; FamilyID,SubTypeID:word);
begin
  PacketAppend16(p, swap(FamilyID));
  PacketAppend16(p, swap(SubTypeID));
  PacketAppend16(p, swap($0000));
  PacketAppend16(p, Swap(random($FF))); // 00 4D 00 xx
  PacketAppend16(p, Swap(SubTypeID));
end;
function PacketRead8(p : PPack): byte;
var val : byte;
begin
     val := PBYTE(@(p^.data[p^.cursor]))^;
    PacketAdvance(p, sizeof(byte));
    Result := val;
end;
function PacketRead16(p : PPack): word;
var val : word;
begin
     val := PWORD(@(p^.data[p^.cursor]))^;
    PacketAdvance(p, sizeof(word));
    Result := val;
end;
function PacketRead32(p : PPack): longint;
var val : longint;
begin
    val := PLONG(@(p^.data[p^.cursor]))^;
    PacketAdvance(p, sizeof(longint));
    Result := val;
end;
procedure PacketAppendB_String(p:PPack; s:string);
var i : integer;
begin
  PacketAppend8(p, length(s));
  for i:=1 to length(s) do
  PacketAppend8(p,byte(s[i]));
end;
procedure PacketAppendString(p:PPack; s:string);
var len : word;
  sStr : string;
  i : integer;
begin
  if s <> '' then begin
  sStr := s+#0;
  len := length(sStr);
  PacketAppend16(p, len);
  for i:=1 to len do begin
  PBYTE(@(p^.data[p^.cursor]))^ := byte(sStr[i]);
  PacketAdvance(p,sizeof(byte));
  end;
  end else begin
  PacketAppend16(p, 1);
  PacketAppend8(p,0);
  end;
end;
function PacketReadString(p:PPack):string;
var length : word;
  sTemp : string;
  dTemp : TByteArray;
begin
  length := PacketRead16(p);
  setlength(sTemp,length-1);
  PacketRead(p, @dTemp,length);
  if length = 1 then Result := ''
  else begin
  move(dTemp,sTemp[1],length-1); // -1 = without #00
  Result := sTemp;
  end;
end;
function PacketReadB_String(p:PPack):string;
var length : byte;
  dTemp : TByteArray;
begin
  length := PacketRead8(p);
  setlength(Result,length);
  PacketRead(p, @dTemp,length);
  move(dTemp,Result[1],length);
end;
procedure PacketAppend(p:PPack; what:pointer; len:integer);
begin
  move(what^, PBYTE(@(p^.data[p^.cursor]))^, len);
  PacketAdvance(p, len);
end;
procedure PacketRead(p:PPack; Buf:pointer; length:integer);
begin
  move(p^.data[p^.cursor],Buf^,length);
  PacketAdvance(p, length);
end;
procedure PacketAppendStringFE(p:PPack; s:string);
var len : integer;
begin
  if s <> '' then begin
  len := length(s);
  PacketAppend(p, PChar(s[1]), len);
  end;
  PacketAppend8(p, $FE);
end;
procedure PacketBegin(p:PPack);
begin
  p^.cursor := 0;
end;
procedure PacketEnd(p:PPack);
begin
  p^.cursor := p^.length;
end;
procedure PacketGoto(p:PPack; i:integer);
begin
  PacketBegin(p);
  PacketAdvance(p, i);
end;
function PacketPos(p:PPack):word;
begin
  result := p^.cursor;
end;
function Swap(InWord:word):word;
begin
  Result := (lo(InWord)shl 8)+hi(InWord);
end;

function DSwap(InLong:longint):longint;assembler;
asm
  MOV EAX,InLong
  BSWAP EAX
  MOV Result,EAX
end;
function Dim2Hex(what:pointer;len:integer):string;
var i : integer;
  b : byte;
begin
  Result:='';
  for i:=0 to len-1 do begin
  b:=PByteArray(what)^[i];
  Result := Result+inttohex(b,2)+' ';
  end;
end;
function Dim2Str(what:pointer;len:integer):string;
var i : integer;
  b : byte;
begin
  Result:='';
  for i:=0 to len-1 do begin
  b:=PByteArray(what)^[i];
  if b<32 then b:=byte('.');
  Result := Result+char(b)+' ';
  end;
end;
(****************************************************************)
procedure StrToIP(sIP:string; var aIP:IParray);
var sTemp : string;
  aPos,bPos,cPos : integer;
begin
  longint(aIP) := 0; if sIP = '' then exit;
  sTemp := sIP;
  aPos := pos('.',sTemp); if aPos = 0 then exit;
  sTemp[aPos] := 'a';
  bPos := pos('.',sTemp); if bPos = 0 then exit;
  sTemp[bPos] := 'b';
  cPos := pos('.',sTemp); if cPos = 0 then exit;
  sTemp[cPos] := 'c';
  try aIP[0] := strtoint(copy(sTemp,1,aPos-1)); except end;
  try aIP[1] := strtoint(copy(sTemp,aPos+1,bPos-aPos-1)); except end;
  try aIP[2] := strtoint(copy(sTemp,bPos+1,cPos-bPos-1)); except end;
  try aIP[3] := strtoint(copy(sTemp,cPos+1,length(sTemp)-cPos)); except end;
end;
(****************************************************************)
function IPtoStr(var aIP:IParray):string;
begin
  IPtoStr := s(aIP[0])+'.'+s(aIP[1])+'.'+s(aIP[2])+'.'+s(aIP[3]);
end;
(****************************************************************)
function UTC2LT(year,month,day,hour,min:integer) : TDateTime;
var r : longword;
  Time : TDateTime;
  TimeStamp : TTimeStamp;
  TZ_INFO : TIME_ZONE_INFORMATION;
begin
  r := GetTimeZoneInformation(_Time_Zone_Information(TZ_INFO));
  TimeStamp := DateTimeToTimeStamp(EncodeDate(year,month,day)+EncodeTime(hour,min,0,0));
  Time := TimeStampToDateTime(TimeStamp);
  if r = TIME_ZONE_ID_UNKNOWN    then Result := Time
  else Result := Time-((TZ_INFO.Bias+60)/1440);
end;
(****************************************************************)
function Now2DateTime : TDateTime;
var Time : TDateTime;
  TimeStamp : TTimeStamp;
  year,month,day,hour,min,secs,msecs : word;
begin
  DecodeDate(Now, Year, Month, Day);
  DecodeTime(Now,Hour,Min,Secs,Msecs);
  TimeStamp := DateTimeToTimeStamp(EncodeDate(year,month,day)+EncodeTime(hour,min,0,0));
  Time := TimeStampToDateTime(TimeStamp);
  Result := Time;
end;
function SecsSince1970:longint;
var s1970, sNow : TTimeStamp;
begin
  s1970 := DateTimeToTimeStamp(EncodeDate(1970,1,1));
  sNow := DateTimeToTimeStamp(Now);
  SecsSince1970 := Floor(TimeStampToMSecs(sNow)/1000 - TimeStampToMSecs(s1970)/1000);
end;
function Get_my_IP: string;
var wVersionRequested : WORD;
  wsaData : TWSAData;
  p : PHostEnt;
  s : array[0..128] of char;
  p2 : pchar;
begin
  Result := '127.0.0.1';
  try {Start up WinSock}
  wVersionRequested := MAKEWORD(1, 1);
  WSAStartup(wVersionRequested, wsaData);
  try {Get the computer name}
  GetHostName(@s, 128);
  p := GetHostByName(@s);
  {Get the IpAddress}
  p2 := iNet_ntoa(PInAddr(p^.h_addr_list^)^);
  Result := p2;
  except end;
  try {Shut down WinSock} WSACleanup; except end;
  except end;
  OL := Result <> '127.0.0.1';
end;
(****************************************************************)
function Calc_Pass(PassIN : string):string;
const pass_tab : array[1..16] of byte =
  ($F3,$26,$81,$C4,$39,$86,$DB,$92,
  $71,$A3,$B9,$E6,$53,$7A,$95,$7C);
var i : integer;
begin
  Result := '';
  for i:=1 to length(PassIN) do
  Result := Result+char(byte(PassIN[i]) xor pass_tab[i]);
end;
function s(i : longint) : string;
begin
  Result := inttostr(i);
end;
procedure M(Memo:TMemo; s:string);
begin
  Memo.Lines.Add(s);
end;
end.