Program TestHexDump2;
// ===========================================================
// Tento program je Macro pro 602text z baliku fy Software602
// 602Pro PC SUITE
// Produkt 602Pro PC SUITE jako demo lze nalezt na CD casopisu
// CHIP a PC WORLD
// Predplatitele casopisu si mohli produkt ZDARMA registrovat!
// ===========================================================

// Macro TestHexDump2:
// 0) Nakopirujte LnkSofMA.DLL a LnkSofMA.INI do adresare,
//    kde je Vas 602text.exe  a v souboru LnkSofMA.INI
//    nastavte parametry portu COM, pres ktery je pripojen
//     ridici system s Vasi Kit-Builder aplikaci
// 1) Otevrete novy prazdny soubor
// 2) Odstartujte toto macro
// 3) Vyckejte po dobu komunikace
// 4) Vase cekani bude odmeneno vytvorenym HexDump
//    vypisem celociselnych registru
//    a vypisem real registru do souboru
// 5) Vy sami si muzete napsat podobna macra, ktera pro
//    Vas vytvori protokoly s aktualnimi daty
//     z Vasi aplikace

// Nasleduje zdrojovy kod macra,
// toto macro v prostredi 602text prelozte
// -----------------------------------------
// Otevreni Kanalu, komunikace Zavreni

const
  { CallBack type = hodnoty parametru XTYP:word pro 
TSofMACallBackProc }
  CBTYPE_None       =0; { nedefinovany }
  CBTYPE_Connect    =1; { Master Automat oznamuje navazani 
komunikace,
                          lpMessBuff^=Node }
  CBTYPE_DisConnect =2; { Master Automat oznamuje ztratu   
komunikace,
                          lpMessBuff^=Node }
  CBTYPE_Mess       =3; { Master Automat predava prijatou 
zpravu,
                          lpMessBuff^="zprava"  }

  BAS_Closed       =0;
  BAS_Opened       =1;
  BAS_Connected    =2;
  BAS_DisConnected =3;

  mrNone  =0;
  mrOK    =1;
  mrCancel=2;
  mrAbort =3;

type
  tAChar =array[0..255] of char;
  pointer=^char;
  PChar  =^tAChar;
  word   =short;
  longint=integer;
  byte   =char;
  Realp  =array[0..5] of char;
  lpRealp=^Realp;

const
{==============================================================
================}
{         S l e d o v a n i   O n - L i n e   p a r a m e t r 
u                }
{==============================================================
================}
gcmd_None         = 0; { prazdny prikaz }
gcmd_Abort        = 1; { prikaz pro uvedeni automatu do klidu 
z lib.
                         stavu(nerusi jej!) }
gcmd_DoneReq      = 2; { prikaz pro zruseni procesu (pred 
gcmd_Done nemusi
                         predchazet gcmd_Abort)  }
gcmd_Result       = 3; { TGCmd_Result  Vysledek operace 
(0=O.K., >0=chyba) }
gcmd_Timeout      = 5; { zprava po vycerpani timeoutu }

gcmd_GetParamVal  = 64; { T???_GetParamVal SLV <-  MAS zadost 
o
                          parametr/parametry }
gcmd_PutParamVal  = 65; { T???_ParamValue  SLV <-> MAS zapis
                          parametru/parametru   }

type
{--------------------------------------------------------------
----------------}
{      uvodni blok (hlavicka) kazde zpravy prenasene 
protokolem SofL2          }
{--------------------------------------------------------------
----------------}
TProcIdent      = byte;     { typ identifikatoru procesu ve 
zprave }
TProcInst       = byte;     { typ instance procesu ve zprave   
    }
TProcLogA       = word;     { typ logicke adresy ve zprave     
    }
TPMCode         = byte;     { typ kodu zpravy                  
    }

TProcAddr       = record    { --- celkem  (4) byty 
--------------- }
  XIdent       :TProcIdent; {(1) identifikator procesu  }
  XInst        :TProcInst;  {(1) cislo instance procesu }
  XLogA        :TProcLogA;  {(2) logicka adresa  }
end;

TProcMessHeader = record    { --- celkem (14) bytu 
--------------- }
  BuffSize     :word;       {(2) delka vcetne nasledujicich 
Data   }
  DDETrans     :byte;       {(1) ddet_xxxx (vyuziti pro DDE)   
    }
  Destin       :TProcAddr;  {(4) adresa prijemce               
    }
  Source       :TProcAddr;  {(4) adresa odesilatele            
    }
  MNo          :byte;       {(1) cislo vysilane zpravy         
    }
  ANo          :byte;       {(1) cislo posledni prijate zpravy 
    }
  MCode        :TPMCode;    {(1) identifikator/kod prikazu 
zpravy  }
end;

const
  g_nevimco          = 1000;  { promenna horni mez pro 
dynamicke pole parametru }
  g_ResultSzMaxIndx  =   64;  { max. delka textu chyboveho 
hlaseni ve zprave    }

type
  { Typ datove casti potvrzovaci zpravy, kterou SLAVE 
potvrzuje (ResultCode=0)
    bezchybne akceptovani, nebo hlasi chybu (ResultCode<>0).
    V polozce ResultSz muze SLAVE predat text chyboveho 
hlaseni }
  Tgcmd_Result  = record { zprava muze byt promenne delky dle 
ResultSz }
    ResultCode :word;   { 0=OK, ostatni kod chyby }
    ResultSz   :array[0..g_ResultSzMaxIndx] of char; { null 
terminated str }
  end;


type
  TDscrMsk_Type    =byte;
const  { konstanty pro vytvareni descriptoru zaznamu }
  DscrMsk_First    =16; { bit oznacujici 1. byte parametru }
  DscrMsk_TypPol   =15; { maska na bity oznacujici typ polozky 
}
  DscrMsk_undef    =0;  { dosud nedefinovany byte masky }

  DscrMsk_byte     =1;  { parametr = byte    nebo pole bytu    
 }
  DscrMsk_word     =2;  { parametr = word    nebo pole wordu   
 }
  DscrMsk_integer  =3;  { parametr = integer nebo pole 
integeru }
  DscrMsk_longint  =4;  { parametr = longint nebo pole 
longintu }
  DscrMsk_dword    =5;  { parametr = dword   nebo pole dwordu  
~ double word }
  DscrMsk_string   =6;  { parametr = pascalsky string }
  DscrMsk_real     =7;  { parametr = pascalsky 6-ti byte real  
}
  DscrMsk_DosDaTi  =8;  { parametr = longint chapany jako 
MS-DOS PackTime  }
  DscrMsk_Bit      =9;  { parametr = byte chapany po bitech 
0..7 }

  DscrMsk_TypPolMax=9;  { maximalni pripustna hodnota typu 
polozky  }

type
{-------- Adresace bloku registru v Kit-Builderu 
-------------------------}
TKbd_BlockHeader = record { identifikace bloku registru }
  TREC    :TDscrMsk_Type; { typ KitBulder registru }
  RADDR   :word;          { poc adresa bloku registru v 
KitBuilderu  }
  RCNT    :word;          { pocet registru v bloku ~ v poli 
registru }
end;

{ Typ datove casti zpravy }
TKbd_GetParamVal  = record { pozadavek na poslani bloku 
registru
                             z KitBuilderu }
  RqBlockHd  :TKbd_BlockHeader; { pozadovany blok registru }
end;
PKbd_GetParamVal=^TKbd_GetParamVal;

{ Typ datove casti zpravy }
TKbd_PutParamVal= record { posilany blok registru do/z 
KitBuilderu }
  BlockHd  :TKbd_BlockHeader; { identifikace posilaneho bloku 
registru }
  RegBlock :array[0..g_nevimco] of byte; { posilany blok 
registru }
end;
PKbd_PutParamVal =^TKbd_PutParamVal;


function  
GetVersion(AVerBuff:PChar;AVerBuffSize:short):integer;
external "LnkSofMA.DLL" name "LnkSofMA_GetVersion";

procedure SetDebugMode(ADM:integer;ASysfFl:Boolean);
external "LnkSofMA.DLL" name "LnkSofMA_SetDebugMode";

function  ExecDlgDebugDM(lpDebugDM_TrRec:pointer):integer;
external "LnkSofMA.DLL" name "LnkSofMA_ExecDlgDebugDM";

procedure ExecSetDebugMode;
external "LnkSofMA.DLL" name "LnkSofMA_ExecSetDebugMode";


procedure ChannelCreate(ASofMACallBackProc:pointer;
                        ASofMANotifWndHandle:integer;
                        ASofMANotifUserMsg  :integer);
external "LnkSofMA.DLL" name "LnkSofMA_ChannelCreate";

procedure ChannelDestroy;
external "LnkSofMA.DLL" name "LnkSofMA_ChannelDestroy";

function  MessTxD(lpMessBuff:PChar;wMessLen:short):integer;
external "LnkSofMA.DLL" name "LnkSofMA_MessTxD";

procedure DisConnectRq;
external "LnkSofMA.DLL" name "LnkSofMA_DisConnectRq";

procedure ConnectRq;
external "LnkSofMA.DLL" name "LnkSofMA_ConnectRq";

function  GetMABaseState:short;
external "LnkSofMA.DLL" name "LnkSofMA_GetMABaseState";

function  GetSLConnectFlg(ANode:byte):byte;
external "LnkSofMA.DLL" name "LnkSofMA_GetSLConnectFlg";

procedure GetSLMessCounters(ANode:byte;
                            lpOKCounter,lpRepCounter:pointer);
external "LnkSofMA.DLL" name "LnkSofMA_GetSLMessCounters";

function LnkSofMA_QOutFIFOEmpty:byte;
external "LnkSofMA.DLL" name "LnkSofMA_QOutFIFOEmpty";

function  GetFromOutFIFO(var XTYP:short;
                         
lpOutBuff:PChar;wOutBuffSize:short):short;
external "LnkSofMA.DLL" name "LnkSofMA_GetFromOutFIFO";

function  WaitForFIFO(dwTimeOut:integer):integer;
external "LnkSofMA.DLL" name "LnkSofMA_WaitForFIFO";
function  QuietWaitForFIFO(dwTimeOut:integer):integer;
external "LnkSofMA.DLL" name "LnkSofMA_QuietWaitForFIFO";

function  PtrToPChar(APtr:pointer):PChar;
external "LnkSofMA.DLL" name "LnkSofMA_PtrToPChar";

function LnkByteStrHex(B:Byte;OutStr:PChar;MaxLen:word):word;
external "LnkSofMA.DLL" name "LnkSofMA_ByteStrHex";
          
function LnkWordStrHex(W:Word;OutStr:PChar;MaxLen:word):word;
external "LnkSofMA.DLL" name "LnkSofMA_WordStrHex";

function 
LnkLongIntStrHex(L:LongInt;OutStr:PChar;MaxLen:word):word;     
  
external "LnkSofMA.DLL" name "LnkSofMA_LongIntStrHex";

function 
LnkPointerStrHex(P:pointer;OutStr:PChar;MaxLen:word):word;     
  
external "LnkSofMA.DLL" name "LnkSofMA_PointerStrHex";

function LnkBufferStrHex(P:pointer;L:word;
                         OutStr:PChar;MaxLen:word):word;
external "LnkSofMA.DLL" name "LnkSofMA_BufferStrHex";

function LnkRealStrDec(R:lpRealp;Len:Byte;Flt:Byte;
                       OutStr:PChar;MaxLen:word):word;
external "LnkSofMA.DLL" name "LnkSofMA_RealStrDec";

function 
LnkRealStrExp(R:lpRealp;Len:Byte;OutStr:PChar;MaxLen:word):word
;
external "LnkSofMA.DLL" name "LnkSofMA_RealStrExp";

{==============================================================
============}
{               P o m o c n e   f u n k c e                    
            }
{==============================================================
============}
procedure FillChar(Buff:PChar;Size:short;ch:char);
var i:integer;
begin
  for i:=0 to Size-1 do
    Buff^[i]:=ch;
end;

type 
  tString255=string[255];
  pString255=^tString255;

{ Finta pro pretypovani na universalni PChar }
function  PtrStr255ToPChar(APtr:pString255):PChar;
external "LnkSofMA.DLL" name "LnkSofMA_PtrToPChar";

function ByteStrHex(B:Byte):tString255;
var S:tString255;
begin
  LnkByteStrHex(B,PtrStr255ToPChar(Addr(S)),SizeOf(S));
  ByteStrHex:=S;
end;

function WordStrHex(W:word):tString255;
var S:tString255;
begin
  LnkWordStrHex(W,PtrStr255ToPChar(Addr(S)),SizeOf(S));
  WordStrHex:=S;
end;

function RealStrExp(R:lpRealp;Len:Byte):tString255;
var S:tString255;
begin
  LnkRealStrExp(R,Len,PtrStr255ToPChar(Addr(S)),SizeOf(S));
  RealStrExp:=S;
end;

function GetSofMAVerStr:tString255;
var S:tString255;
begin
  GetVersion(PtrStr255ToPChar(Addr(S)),SizeOf(S));
  GetSofMAVerStr:=S;
end;

{--------------------------------------------------------------
-----------}
{          Z a d o s t  o   p o s l a n i    z p r a v y       
           }
{--------------------------------------------------------------
-----------}
type
TGetParamValMess = record
  HED :TProcMessHeader;
  REC :TKbd_GetParamVal;
end;
PGetParamValMess=^TGetParamValMess;

TPutParamValMess=record
  HED :TProcMessHeader;
  REC :TKbd_PutParamVal;
end;
PPutParamValMess=^TPutParamValMess;


{ Finta pro pretypovani na universalni PChar }
function  Kbd_GetParamValToPChar(APtr:PKbd_GetParamVal):PChar;
external "LnkSofMA.DLL" name "LnkSofMA_PtrToPChar";

{ Finta pro pretypovani na universalni PChar }
function  Kbd_PutParamValToPChar(APtr:PKbd_PutParamVal):PChar;
external "LnkSofMA.DLL" name "LnkSofMA_PtrToPChar";

{ Finta pro pretypovani na universalni PChar }
function  GetParamValMessToPChar(APtr:PGetParamValMess):PChar;
external "LnkSofMA.DLL" name "LnkSofMA_PtrToPChar";

{ Finta pro pretypovani na universalni PChar }
function  PutParamValMessToPChar(APtr:PPutParamValMess):PChar;
external "LnkSofMA.DLL" name "LnkSofMA_PtrToPChar";

var
GlbKbd_GetParamVal     :TKbd_GetParamVal; { Init hodnoty }
GlbKbd_PutParamVal     :TKbd_PutParamVal; { Init hodnoty }
GlbKbd_MessGetParam    :TGetParamValMess; { Init hodnoty }

KbdRegistry :array[0..4095] of byte;
KbdRealReg  :array[0..255] of Realp;

procedure InitGlbKbd;
var P:PChar;
begin
  P:= Kbd_GetParamValToPChar(Addr(GlbKbd_GetParamVal));
  FillChar(P,Sizeof(GlbKbd_GetParamVal),Chr(0));
  GlbKbd_GetParamVal.RqBlockHd.TREC :=Chr(DscrMsk_byte);  { 
typ registru }
  GlbKbd_GetParamVal.RqBlockHd.RADDR:=2048;{ poc adresa bloku 
registru   }
  GlbKbd_GetParamVal.RqBlockHd.RCNT :=32;  { pocet registru v 
bloku }
  P:= Kbd_PutParamValToPChar(Addr(GlbKbd_PutParamVal));
  FillChar(P,Sizeof(GlbKbd_PutParamVal),Chr(0));
  GlbKbd_PutParamVal.BlockHd.TREC   :=Chr(DscrMsk_byte); { typ 
 registru }
  GlbKbd_PutParamVal.BlockHd.RADDR  :=2048;{ poc adresa bloku 
registru   }
  GlbKbd_PutParamVal.BlockHd.RCNT   :=1;   { pocet registru v 
bloku      }
  { -- Definovani polozek hlavicky zpravy -- zacatek 
------------------- }
  P:= GetParamValMessToPChar(Addr(GlbKbd_MessGetParamVal));
  FillChar(P,SizeOf(GlbKbd_MessGetParamVal),chr(0)); { 
vynulovani }
  
GlbKbd_MessGetParamVal.HED.BuffSize:=SizeOf(GlbKbd_MessGetParamVal);
  {(4) adresa prijemce    [86,01,4001]  }
  GlbKbd_MessGetParamVal.HED.Destin.XIdent:=Chr(134);{ proces 
PRT_KBPAR_S}
  GlbKbd_MessGetParamVal.HED.Destin.XInst :=Chr(1);{ cislo 
inst procesu  }
  GlbKbd_MessGetParamVal.HED.Destin.XLogA :=16385; { log adr 
procesu     }
  {(4) adresa odesilatele [85,01,2001]  }
  GlbKbd_MessGetParamVal.HED.Source.XIdent:=Chr(133);{proces 
PRT_KBPAR_M }
  GlbKbd_MessGetParamVal.HED.Source.XInst :=Chr(1);  { cislo 
inst procesu}
  GlbKbd_MessGetParamVal.HED.Source.XLogA :=8193;{ logicka adr 
procesu   }
  GlbKbd_MessGetParamVal.HED.MNo :=Chr(0); { cislo vysilane 
zpravy       }
  GlbKbd_MessGetParamVal.HED.ANo :=Chr(0); { cislo posl. 
prijate zpravy  }
  GlbKbd_MessGetParamVal.HED.MCode:=Chr(gcmd_GetParamVal); 
{ident zpravy }
  GlbKbd_MessGetParamVal.REC:=GlbKbd_GetParamVal;
  { -- Definovani polozek hlavicky zpravy -- 
konec---------------------- }
end;


{==============================================================
============}
function 
SendKbd_GetParamVal(ATREC:byte;ARADDR,ARCNT:word):integer;
var P:PChar;
begin
  GlbKbd_MessGetParamVal.REC.RqBlockHd.TREC :=ATREC; { typ 
registru      }
  GlbKbd_MessGetParamVal.REC.RqBlockHd.RADDR:=ARADDR;{ poc 
adresa bloku  }
  GlbKbd_MessGetParamVal.REC.RqBlockHd.RCNT :=ARCNT; { pocet 
reg v bloku }
  P:= GetParamValMessToPChar(Addr(GlbKbd_MessGetParamVal));
  {======= V O L A N I   L n k S o f M A . D L L 
========================}
  
SendKbd_GetParamVal:=MessTxD(P,SizeOf(GlbKbd_MessGetParamVal));

  
{==============================================================
========}
end;

{==============================================================
============}
procedure ByteKomunikace;
var  QXTYP       :word;
     mrResult    :integer;
     Connected   :Boolean;
     WRADDR      :word;
     RRADRR,RLen :word;
     P           :PChar;
     RecMessPutParam :TPutParamValMess;
     MessLen         :word;
     i               :integer;
begin
  WRADDR   :=0;
  P:= PutParamValMessToPChar(Addr(RecMessPutParam));
  if GetMABaseState=BAS_Connected
  then begin
         Connected:=true;
         SendKbd_GetParamVal(Chr(DscrMsk_byte),WRADDR,32);
       end  
  else Connected:=false;
  repeat
    mrResult:=QuietWaitForFIFO(4000);
    if mrResult=mrOK then
    begin
      
MessLen:=GetFromOutFIFO(QXTYP,P,SizeOf(RecMessPutParam));
      case QXTYP of
        CBTYPE_Connect:
          begin
            Connected:=true;
            WRADDR   :=0;
            SendKbd_GetParamVal(Chr(DscrMsk_byte),WRADDR,32);
          end;
        CBTYPE_DisConnect:
          begin
            Connected:=false;
          end;
        CBTYPE_Mess:
          begin
            RRADRR:= RecMessPutParam.REC.BlockHd.RADDR;
            RLen  := RecMessPutParam.REC.BlockHd.RCNT;
            for i:=0 to RLen-1 do
              KbdRegistry[RRADRR+i]:= 
RecMessPutParam.REC.RegBlock[i];
            WRADDR:=WRADDR+32;
            if WRADDR<4096
            then begin
                   
SendKbd_GetParamVal(Chr(DscrMsk_byte),WRADDR,32);
                 end
            else begin
                   mrResult:=mrAbort;
                 end;
          end;
      end;
    end;
 until (mrResult>=mrAbort);
end;

{==============================================================
============}
procedure RealKomunikace;
var  QXTYP       :word;
     mrResult    :integer;
     Connected   :Boolean;
     WRADDR      :word;
     RRADRR,RLen :word;
     P           :PChar;
     RecMessPutParam :TPutParamValMess;
     MessLen         :word;
     i,j             :integer;
begin
  WRADDR   :=0;
  P:= PutParamValMessToPChar(Addr(RecMessPutParam));
  if GetMABaseState=BAS_Connected
  then begin
         Connected:=true;
         SendKbd_GetParamVal(Chr(DscrMsk_real),WRADDR,4);
       end  
  else Connected:=false;
  repeat
    mrResult:=QuietWaitForFIFO(4000);
    if mrResult=mrOK then
    begin
      
MessLen:=GetFromOutFIFO(QXTYP,P,SizeOf(RecMessPutParam));
      case QXTYP of
        CBTYPE_Connect:
          begin
            Connected:=true;
            WRADDR   :=0;
            SendKbd_GetParamVal(Chr(DscrMsk_real),WRADDR,4);
          end;
        CBTYPE_DisConnect:
          begin
            Connected:=false;
          end;
        CBTYPE_Mess:
          begin
            RRADRR:= RecMessPutParam.REC.BlockHd.RADDR;
            RLen  := RecMessPutParam.REC.BlockHd.RCNT;
            for i:=0 to (RLen-1)*6 do
              for j:=0 to 5 do
                KbdRealReg[RRADRR+i,j]:= 
RecMessPutParam.REC.RegBlock[i*6+j];
            WRADDR:=WRADDR+4;
            if WRADDR<256
            then begin
                   
SendKbd_GetParamVal(Chr(DscrMsk_real),WRADDR,4);
                 end
            else begin
                   mrResult:=mrAbort;
                 end;
          end;
      end;
    end;
 until (mrResult>=mrAbort);
end;

procedure InsHexDump;
var S :tString255;
    i,j,k :integer;
begin
  UseFontOfNameExt('Courier New',238);
  SetFormatFont(kCHPsize,8);
  CaretEnd(false);
  S:=GetSofMAVerStr;
  InsertText(S);
  InsertNewPara;
  S:='Hex DUMP of Kit-Builder ordinal registers';
  InsertText(S);
  InsertNewPara;
  for i:=0 to 4095 do
  begin
    if (i mod 16)=0 then
    begin
      InsertNewPara;
      S:='Adr=$'+WordStrHex(i)+':   ';
      InsertText(S);
    end;
    S:= ByteStrHex(KbdRegistry[i])+Char2Str(' ');
    InsertText(S);
  end;
end;

procedure InsRealDump;
var S :tString255;
    i,j,k :integer;
begin
  UseFontOfNameExt('Courier New',238);
  SetFormatFont(kCHPsize,8);
  CaretEnd(false);
  S:=GetSofMAVerStr;
  InsertText(S);
  InsertNewPara;
  S:='DUMP of Kit-Builder real registers';
  InsertText(S);
  InsertNewPara;
  for i:=0 to 255 do
  begin
    if (i mod 4)=0 then
    begin
      InsertNewPara;
      S:='Adr=$'+WordStrHex(i)+':   ';
      InsertText(S);
    end;
    S:= RealStrExp(Addr(KbdRealReg[i]),chr(9))+Char2Str(' ');
    InsertText(S);
  end;
end;

begin
  InitGlbKbd;
  ChannelCreate(nil,0,0);
  ByteKomunikace;
  RealKomunikace;
  ChannelDestroy; 
  InsHexDump;
  InsertNewPage;
  InsRealDump;end. 