perlmqmsgque 9.0
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 perlmqmsgque.

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 perlmqmsgque protocoll and build together a flat structure.

The GOAL for this setup is:

CODE client

#+
#:   @file         example/perl/testclient.pl
#:   @brief        testclient.pl - 06 Jan 2023 - aotto1968
#:   @copyright    (C) NHI - #1 - Project - Group
#:                 This software has NO permissions to copy,
#:                 please contact AUTHOR for additional information
#:   @version      3229edb4ba23c4273fd3e1cd50d2f1ada9252a7b
#:   @date         Fri Jan 6 22:13:29 2023 +0100
#:   @author       aotto1968 <aotto1968@t-online.de>
#:

use strict;
use warnings;
use PerlMqMsgque;
use File::Spec::Functions;
use File::Basename;
use English;

## my helper
sub Get {
  my $ctx = shift;
  my $RET = "";
  $ctx->SendSTART();
  $ctx->SendEND_AND_WAIT("GTCX");
  $RET .= $ctx->ConfigGetName();
  $RET .= "+";
  $RET .= $ctx->ReadC();
  $RET .= $ctx->ReadC();
  $RET .= $ctx->ReadC();
  $RET .= $ctx->ReadC();
  $RET .= $ctx->ReadC();
  $RET .= $ctx->ReadC();
  return $RET;
}

package main;

  ## setup the clients
  my $server = catfile (dirname($0), "testserver.pl");
  my @LIST1 = ("--prefix", "c", "--postfix", "1", @ARGV);
  my @LIST0 = ("--prefix", "c", "--postfix", "0", "--debug", $ENV{"TS_DEBUG"}, "@",
                  $EXECUTABLE_NAME, $server, "--prefix", "s");

  ## create object
  my $c0    = MqContextC->new();
  my $c00   = MqContextC->new();
  my $c01   = MqContextC->new();
  my $c000  = MqContextC->new();
  my $c1    = MqContextC->new();
  my $c10   = MqContextC->new();
  my $c100  = MqContextC->new();
  my $c101  = MqContextC->new();

  ## make the test
  eval {

    ## setup object link
    $c0->LinkCreateVA	      (@LIST0);
    $c00->LinkCreateChildVA   ($c0,  "--postfix", "00");
    $c01->LinkCreateChildVA   ($c0,  "--postfix", "01");
    $c000->LinkCreateChildVA  ($c00, "--postfix", "000");
    $c1->LinkCreateVA	      (@LIST1);
    $c10->LinkCreateChildVA   ($c1,  "--postfix", "10");
    $c100->LinkCreateChildVA  ($c10, "--postfix", "100");
    $c101->LinkCreateChildVA  ($c10, "--postfix", "101");

    ## do the tests
    print Get($c0)    . "\n";
    print Get($c00)   . "\n";
    print Get($c01)   . "\n";
    print Get($c000)  . "\n"; 
    print Get($c1)    . "\n"; 
    print Get($c10)   . "\n"; 
    print Get($c100)  . "\n"; 
    print Get($c101)  . "\n"; 
  } or do {
    $c0->ErrorCatch ($@);
  };
  $c1->LinkDelete();
  $c0->Exit();


CODE server

#+
#:   @file         example/perl/testserver.pl
#:   @brief        testserver.pl - 06 Jan 2023 - aotto1968
#:   @copyright    (C) NHI - #1 - Project - Group
#:                 This software has NO permissions to copy,
#:                 please contact AUTHOR for additional information
#:   @version      3229edb4ba23c4273fd3e1cd50d2f1ada9252a7b
#:   @date         Fri Jan 6 22:13:29 2023 +0100
#:   @author       aotto1968 <aotto1968@t-online.de>
#:

use strict;
use warnings;
use PerlMqMsgque;

package testserver;
use parent qw(PerlMqMsgque::MqContextC);

  sub GTCX {
    my $ctx = shift;
    $ctx->SendSTART();
    $ctx->SendI($ctx->LinkGetCtxId());
    $ctx->SendC("+");
    if ($ctx->LinkIsParent()) {
      $ctx->SendI(-1);
    } else {
      $ctx->SendI($ctx->LinkGetParent()->LinkGetCtxId());
    }
    $ctx->SendC("+");
    $ctx->SendC($ctx->ConfigGetName());
    $ctx->SendC(":");
    $ctx->SendRETURN();
  }

  sub ServerConfig {
    my $ctx = shift;
    $ctx->ServiceCreate("GTCX",\&GTCX)
  }

  sub new {
    my $class = shift;
    my $ctx = $class->SUPER::new(@_);
    $ctx->ConfigSetServerSetup(\&ServerConfig);
    return $ctx;
  }

package main;

  my $srv = MqFactoryC->Add("testserver")->New();
  eval {
    $srv->LinkCreateVA(@ARGV);
    $srv->ProcessEvent(MqWaitOnEventE->{FOREVER});
  } or do {
    $srv->ErrorCatch($@);
  };
  $srv->Exit();

1;