sub main {
    my $self = shift;
    my $paddr;
    my $waitedpid = 0;
    sub spawn;
    sub logmsg;
    
    $server = GlxInetServer->new($port{"servd"},1,"servd");

    for ( $waitedpid = 0; ($paddr = $server->accept()) || $waitedpid; 
+$waitedpid = 0, $server->close()) {
        next if $waitedpid and not $paddr;

        spawn sub{

            $client_modd = GlxInetClient->new($port{"modd"},1,"servd")
+;
            $server->write("440 Servd ready for commands");
            my $in=$server->read();
            unless (defined $in) { $self->unexpected; last };

            SWITCH: {
                ($in =~ /^status/) && do {
                    $server->write($ob_modds[0]->status);
                    $server->write("OK connecting statd");
                    last SWITCH;
                };
                
                ($in =~ /^something/ && do {
                    ### snip
                    $client_modd->write($in);
                    ### snip
                    $client_modd->close();
                    last SWITCH;
                };
                
                ($in =~ /^bye$/) && do {
                    $server->write("OK");
                    last SWITCH;
                };

                $server->write("450 No such command");
                $client_modd->close();
            } # SWITCH
        }# spawn
    }# for

    sub spawn {
        my $coderef = shift;
        die unless (@_ == 0 && $coderef && ref($coderef) eq 'CODE');
        my $pid;
        if (!defined($pid = fork)){
            logmsg "cannot fork: $!";
            return;
        } elsif ($pid) {
            logmsg "[$pid] listening for ".$server->get_iname()." [", 
+inet_ntoa($server->get_iaddr()),"]";
            return;
        }
        exit &$coderef();
    }
} #main
[download]

# GlxShMem
# this is an replacement for an old SysV IPC shm package ported to Win

package GlxShMem;
use Win32::MMF::Shareable;

sub alloc {
    my $class = shift;
    my $value = @_ ? shift : '';

    my $self = bless {
        OWNER => $$,
    } => $class;
    
    my %options = (
        create => 1,
        exclusive => 1,
        mode => 0666,
        destroy => 1,
        reuse => 1,
        autolock => 1,
    );
    
    $self->{SHMKEY} = $self;
    $self->{SHMKEY} =~ s/(\(.+\))/$1/;
    $self->{SHMKEY} = $1;
    $self->{SHMKEY} =~ s/\(|\)//g;
    $self->{SHMKEY} =~ s/0x//;
    
    while ($self->{SHMKEY} =~ s/\D/$1/) {
        my $h = ord($1);
        $self->{SHMKEY} =~ s/\D/$h/;    
    }
    
    tie $self->{DATA}, 'Win32::MMF::Shareable', $self->{SHMKEY}, {%opt
+ions} or die 'GlxShMem->alloc() : Tie failed\n';
    $self->{DATA} = $value;
    
    return $self;
}

sub get {
    my $self = shift;
    return $self->{DATA};
}

sub put {
    my $self = shift;
    if ($debug) {
       my %options = (
          create => 0,
          exclusive => 0,
          mode => 0666,
          destroy => 1,
          reuse => 1,
          autolock => 1,
     );
    my $ns=tie $self->{DATA}, 'Win32::MMF::Shareable', self->{SHMKEY},
+ {%options} or die 'debug : Tie failed\n';
      $ns->debug();
    }       
    $self->{DATA} = shift;
}

sub DESTROY {
    my $self = shift;
    return unless $self->{OWNER} == $$;
    (tied $self->{DATA})->deletevar($self->{DATA});
}

1;

### end GlxShMem
[download]

package GlxModd;

use strict;
use warnings;
use GlxGlobalVars;
use GlxInetServer;
use GlxShMem;

sub new {

    my $class = shift;
    my $id = shift;
    my $device = shift;
    my $port = shift;
    my $logfile = shift;
    my $debug = shift || 0;
    my $string = shift || '';

    my $self = bless {
        ID => GlxShMem->alloc($id),
        DEVICE => GlxShMem->alloc($device),
        PORT => GlxShMem->alloc($port),
        LOGFILE => GlxShMem->alloc($logfile),
        DEBUG => GlxShMem->alloc($debug),
        STRING => GlxShMem->alloc($string),
        
        STAT => GlxShMem->alloc(0),
    #    MODEM => GlxShMem->alloc(0),
    #    GSM => GlxShMem->alloc(0),
    } => $class;
    
    $self->{STAT}->put(0);
    return $self;
}

sub status {
    my $self=shift;
    return $self->{STAT}->get;
}

sub main {
    my $self = shift;

    my $server = GlxInetServer->new($self->{PORT}->get, $self->{DEBUG}
+->get, $self->{STRING}->get);

    for ( ; $server->accept() ; $server->close()) {
        my $in = $server->read();

        SWITCH: {

            ($in =~ /^something/) && do {
                $server->write("OK");
                
                # FAKE
                my $z=0;
                while (1) {
                $self->{STAT}->put(1);
                    $z++;
                    $server->write($z);
                    sleep 1;
                    last if ($z==20);
                }
                $self->{STAT}->put(0);
            };
        };
    }
} # main

1;
[download]

Hi spaetzle I am very busy this morning so I can not take a closer look at the problem, but I will definitely get back to later you on this.

Hi Roger,
that doesn't matter. I'm working around the problem yet but I'm really interested in to know what you think about.
Spaetzle