theLink 10.0 NHI1 - theKernel - theLink - theConfig - theSq3Lite - theCompiler - theBrain - theGuard
c - tcl - cs - py - rb - jv - cc
Loading...
Searching...
No Matches
Example: Identification-Test

Documentation of the Test-Client-Server tool used for example.test.

INTRODUCTION

The Naming-Test-Tool tool is used to test the name-resolution-feature of tclmqmsgque.

To perform the test 2 tools are used, the testclient and the testserver.

testclient

This tool creates multiple parent and child client-context, all using a --postfix argument to identify unique.

testserver This tool listen on the service GTCX and return the unique identification pattern of the server-context in duty.

All context created, 8x client and 8x server, are connected using the tclmqmsgque protocoll and build together a flat structure.

The GOAL for this setup is:

CODE client

#!/usr/bin/env tclsh
#+
#:   @file         NHI1/example/tcl/testclient.tcl
#:   @brief        testclient.tcl - 26 Jun 2024 - aotto1968
#:   @copyright    (C) NHI - #1 - Project - Group
#:                 This software has NO permission to copy,
#:                 please contact AUTHOR for additional information
#:   @version      08a242faddae5101924d8fe811888e78892a82d9
#:   @date         Wed Jun 26 14:26:21 2024 +0200
#:   @author       aotto1968 <aotto1968@t-online.de>
#:

package require tclmqmsgque

set server  [file join [file dirname [info script]] testserver.tcl]

proc Get {ctx} {
  $ctx SendSTART
  $ctx SendEND_AND_WAIT "GTCX"
  append RET [$ctx ConfigGetName]
  append RET "+"
  append RET [$ctx ReadSTR]
  append RET [$ctx ReadSTR]
  append RET [$ctx ReadSTR]
  append RET [$ctx ReadSTR]
  append RET [$ctx ReadSTR]
  append RET [$ctx ReadSTR]
  return $RET
}

# create object
set LIST [list c0 c00 c01 c000 c1 c10 c100 c101]
foreach F $LIST {
  set FH($F) [tclmqmsgque::MqContextC Create]
}

## create link
$FH(c0)	  LinkCreate		    "--postfix" "0"   "--prefix" "c" "--debug" $env(TS_DEBUG) "@" \
                                                              $env(TCLSH) $server "--prefix" "s"
$FH(c00)  LinkCreateChild $FH(c0)   "--postfix" "00"  
$FH(c01)  LinkCreateChild $FH(c0)   "--postfix" "01"  
$FH(c000) LinkCreateChild $FH(c00)  "--postfix" "000" 
$FH(c1)	  LinkCreate     	    "--postfix" "1"   "--prefix" "c"  {*}$argv
$FH(c10)  LinkCreateChild $FH(c1)   "--postfix" "10"  
$FH(c100) LinkCreateChild $FH(c10)  "--postfix" "100" 
$FH(c101) LinkCreateChild $FH(c10)  "--postfix" "101" 

## do the tests
foreach F $LIST {
  puts [Get $FH($F)]
}

## cleanup
foreach n [lreverse $LIST] {
  $FH($n) Delete
}

CODE server

#!/usr/bin/env tclsh
#+
#:   @file         NHI1/example/tcl/testserver.tcl
#:   @brief        testserver.tcl - 26 Jun 2024 - aotto1968
#:   @copyright    (C) NHI - #1 - Project - Group
#:                 This software has NO permission to copy,
#:                 please contact AUTHOR for additional information
#:   @version      08a242faddae5101924d8fe811888e78892a82d9
#:   @date         Wed Jun 26 14:26:21 2024 +0200
#:   @author       aotto1968 <aotto1968@t-online.de>
#:

package require tclmqmsgque

proc GTCX {ctx} {
  $ctx SendSTART
  $ctx SendI32 [$ctx LinkGetCtxId]
  $ctx SendSTR "+"
  if {[$ctx LinkIsParent]} {
    $ctx SendI32 -1
  } else {
    $ctx SendI32 [[$ctx LinkGetParent] LinkGetCtxId]
  }
  $ctx SendSTR "+"
  $ctx SendSTR [$ctx ConfigGetName]
  $ctx SendSTR ":"
  $ctx SendRETURN
}
proc ServerSetup {ctx} {
  $ctx ServiceCreate "GTCX" GTCX
}
tclmqmsgque::Main {
  tclmqmsgque::MqContextC create srv
  srv ConfigSetServerSetup ServerSetup
  try {
    srv LinkCreate {*}$argv
    srv ProcessEvent MQ_WAIT_FOREVER
  } on error {} {
    srv ErrorCatch
  } finally {
    srv Exit
  }
}