Code KitchenAllgemeines Coder-Forum rund um das Programmieren eigenständiger, ausführbarer Programme.
perl threads::shared - diverse Probleme mit "shared" variablen
Diskussion: perl threads::shared - diverse Probleme mit "shared" variablen im Forum Code Kitchen, in der Kategorie Software Home; Anzeige
Mal wieder ein Perl-Problem... ^^
uname
Code:
Linux keksinat0r.is-a-geek.org 2.6.26-1-amd64 #1 SMP Sat Jan 10 17:57:00 UTC ...
Der Server-Code oben ist mehr oder weniger sinnfreies Rumgebastel, da ich mich intensiver mit Sockets, Tk (Client) und Threads auseinander setzen moechte. Die Performance von dem Teil ist sicher net die beste und das Design wahrscheinlich auch net, aber das soll uns hier 'mal nicht stoeren.
Der Gedanke dahinter:
Master
- Oeffnen des Sockets,
- Starten des "Dispatchers"
- Warten auf Clienten und Starten der Reader & Writer
Reader
- Client-Socket auf Input ueberwachen, Input von Socket lesen und in Warteschlage packen
Writer
- Client-Output-Warteschlange ueberwachen und output in Socket schreiben
Dispatcher
- "Tote"/inaktive/ungenutzte Threads und deren Warteschlangen loeschen
- Eingaben in Warteschlange verarbeiten
- Ausgaben in Warteschlange packen
Soweit so gut... Eigentlich funktioniert das Teil auch, bis auf 2 Dinge:
[1] - wird der Befehl "list" ausgefuehrt bekomme ich folgende Ausgaben:
Server:
Code:
* server listening on 127.0.0.1:3333
* dispatcher started
* waiting for incomming connections...
* client connected: 0 [127.0.0.1:3333]
<<< 8127480 = 127.0.0.1
<<< 8127504 = 53515
* thread 2 and 3 started at 1234469936.33166
8127480 und 8127504 sind die internen Adressen der "shared" variablen. Innerhalb des Threads hat erstere aber einen falschen Wert !?
Im "Master" hat sie direkt nach dem Start des Threads den Wert "127.0.0.1". Im "Dispatcher" spaeter aber "1234469938.798932". Wie kann das sein?
Hat Time::HiRes da seine Finger im Spiel? Immerhin ist das ja ein Timestamp der da drin steht...
[2] - schalte ich den Cleanup wieder ein (NO_CLEANUP => 0) erhalte ich:
Code:
* server listening on 127.0.0.1:3333
* dispatcher started
* waiting for incomming connections...
* client connected: 0 [127.0.0.1:3333]
<<< 9704440 = 127.0.0.1
<<< 9704464 = 60887
* thread 2 and 3 started at 1234470268.20149
* removed crashed: 0
* removed in-queue: 0
* removed out-queue: 0
Thread 3 terminated abnormally: Invalid value for shared scalar at ./chat.pl line 158.
* removed out-queue: 0
Der Thread schmiert also wegen
Code:
if( $#{$::thr_out[$cid]} != -1 )
ab. Aber warum? Hab ich einen Denkfehler im Cleanup?
Und warum loescht er 2 mal die Output-Warteschlange von Client 0? Die Duerfte nach dem 1. Loeschen agrnichtmehr existieren, also duerfte er sie auch netmehr Loeschen wollen...
Zum Testen einfach den Server starten (ggf. mit -v) und via telnet verbinden.
Warum packst du den Kram ausm Master Package nicht einfach in main?
Dann würden diese ganzen (oder zumindest sehr viele) furchtbaren doppel-Doppelpunkte wegfallen. Außerdem erwartet man normalerweise nicht (ich zumindest nicht), dass packages (außer main) einfach so code ausführen. (Ich sehe auch keinerlei Vorteil, den Master package code nicht in main reinzupacken.)
Generell, soll der code eventuell obfuscated sein?
Was soll ein Funktionsname wie v? Steht wahrscheinlich für verbose, aber der Aufruf davon mit ::v und dann noch ohne Parentheses sieht imho sehr kryptisch aus.
Nenns doch einfach debug. Dann wird auch klar, dass die Funktion einfach nur (debug-)Infos ausgibt...
Der Prototype der Funktion ist BTW auch völlig sinnbefreit. Sinn von perl-Prototypen ist compile-time argument checking. Deine Funktion kann nicht falsch aufgerufen werden.
Der prototyp erschwert Verständnis und ist völlig sinnlos.
Code:
$ perldoc perlsub|grep 'A semicolon' -A1
A semicolon separates mandatory arguments from optional arguments. It
is redundant before "@" or "%", which gobble up everything else.
Dann ist deine längste Zeile sage und schreibe 160 Zeichen lang. Das ist völlig inakzeptabel. (Zumindest werd ich mich da nicht durchkämpfen..)
Und warum definierts du einen SIGCHLD Handler, der erstens nichts macht und zweitens selbst wenn er was machen würde sinnfrei wäre, da du sowieso nur mit einem Prozess arbeitest? (Sinn?)
Ich kann leider auch nicht wirklich irgendwas testen. Mein perl coredumped (!) bei Verbindungsaufbau. Meine perl-Version ist 5.8.8.
Code:
$ ./server.pl -v
* server listening on 127.0.0.1:3333
* dispatcher started
* waiting for incomming connections...
* client connected: 0 [127.0.0.1:3333]
Undefined subroutine &Master::is_shared called at ./server.pl line 89.
A thread exited while 4 threads were running.
Segmentation fault (core dumped)
$ perl -Mthreads::shared -e 'print $threads::shared::VERSION'
0.94
is_shared gibts bei meinem threads::shared noch nicht.
Also solange der code stilistisch nicht gewissen Mindestnormen entspricht (9-Level nesting und 160 Zeichen lange Zeilen sind einfach nicht haltbar) und vor allem so lange es nicht mit perl 5.8.8 läuft kann (und in Bezug auf stil: will) ich dir nicht helfen.
Hm, sorry for the rant, du hast ja vorgewarnt. Aber ich versteh einfach viele deiner Entscheidungen nicht.
Original von MontyPerl
Warum packst du den Kram ausm Master Package nicht einfach in main?
Dann würden diese ganzen (oder zumindest sehr viele) furchtbaren doppel-Doppelpunkte wegfallen. Außerdem erwartet man normalerweise nicht (ich zumindest nicht), dass packages (außer main) einfach so code ausführen. (Ich sehe auch keinerlei Vorteil, den Master package code nicht in main reinzupacken.)
Sollte der Uebersichtlichkeit halber sein, da der ganze Krusch in main eigentlich nix mit dem Master zu tun hat - Geschmackssache
Zitat:
Original von MontyPerl
Generell, soll der code eventuell obfuscated sein?
Nein, dass er etwas wirr wirkt liegt daran, dass ich andauernd Code geaendert habe um herauszufinden warum es net so funktioniert wie's soll. Mit er Zeit wird der dann halt sehr chaotisch.
Zitat:
Original von MontyPerl
Was soll ein Funktionsname wie v? Steht wahrscheinlich für verbose, aber der Aufruf davon mit ::v und dann noch ohne Parentheses sieht imho sehr kryptisch aus.
Nenns doch einfach debug. Dann wird auch klar, dass die Funktion einfach nur (debug-)Infos ausgibt...
s.O. Die Funktion fliegt spaeter eh wieder raus. Was hast du ueberhaupt gegen den Aufruf ohne Klammern?
Zitat:
Original von MontyPerl
Der Prototype der Funktion ist BTW auch völlig sinnbefreit. Sinn von perl-Prototypen ist compile-time argument checking. Deine Funktion kann nicht falsch aufgerufen werden.
Der prototyp erschwert Verständnis und ist völlig sinnlos.
Code:
$ perldoc perlsub|grep 'A semicolon' -A1
A semicolon separates mandatory arguments from optional arguments. It
is redundant before "@" or "%", which gobble up everything else.
Ich weiss was das Semikolon bedeutet -.-
Es ist ein ueberbleibsel aus ::v($index, @args);
[quote]Original von MontyPerl
Dann ist deine längste Zeile sage und schreibe 160 Zeichen lang. Das ist völlig inakzeptabel. (Zumindest werd ich mich da nicht durchkämpfen..)[/code]
Wir leben in einer Zeit in der es durchaus Monitore und Editoren gibt, die mehr als 24x80 Zeichen darstellen konnen.
Zitat:
Original von MontyPerl
Und warum definierts du einen SIGCHLD Handler, der erstens nichts macht und zweitens selbst wenn er was machen würde sinnfrei wäre, da du sowieso nur mit einem Prozess arbeitest? (Sinn?)
Hab' ich aus einem Tutorial - Dort wurde behauptet dass dieser Signalhalnder aufgerufen wird, wenn ein Thread versucht von einen geschlossenen Socket zu lesen.
Zitat:
Original von MontyPerl
Ich kann leider auch nicht wirklich irgendwas testen. Mein perl coredumped (!) bei Verbindungsaufbau. Meine perl-Version ist 5.8.8.
Code:
$ ./server.pl -v
* server listening on 127.0.0.1:3333
* dispatcher started
* waiting for incomming connections...
* client connected: 0 [127.0.0.1:3333]
Undefined subroutine &Master::is_shared called at ./server.pl line 89.
A thread exited while 4 threads were running.
Segmentation fault (core dumped)
$ perl -Mthreads::shared -e 'print $threads::shared::VERSION'
0.94
is_shared gibts bei meinem threads::shared noch nicht.
Dann kommentiere die Zeilen doch einfach aus... Sind fuer den Programmablauf sowieso irrelevant.
Zitat:
Original von MontyPerl
Also solange der code stilistisch nicht gewissen Mindestnormen entspricht (9-Level nesting und 160 Zeichen lange Zeilen sind einfach nicht haltbar) und vor allem so lange es nicht mit perl 5.8.8 läuft kann (und in Bezug auf stil: will) ich dir nicht helfen.
Hm, sorry for the rant, du hast ja vorgewarnt. Aber ich versteh einfach viele deiner Entscheidungen nicht.
Warum antwortest du ueberhaupt auf diesen Thread wenn du sowieso keine produktiven Kommentare abliefern kannst? Alles was du hier geschrieben hast bezieht sich auf den mehr oder weniger nicht vorhandenen Programmierstil in dem Code...
Ich habe dazu geschrieben, dass der keineswegs optimal ist. Darum geht es mir hier schliesslich auch nich - Ich will das Teil net verkaufen oder irgendwie produktiv einsetzen - Ich will lediglich Threads, Sockekts und Tk kombinieren...
Perl geht nach dem Motto TIMTOWDI. Warum also kuenstlich wieder so viele Vorschriften machen? Warum darf ich meine Funktionen nicht ohne Klammern aufrufen? Warum darf ich keine Zeilen > 80 Zeichen verwenden? Warum muss mein Code 5.8.8-Kompatibel sein? Warum...
Generell machst du auf mich hier einen sehr eingebildeten Eindruck, ohne dich jetzt angreifen zu wollen. Aber die Tatsache dass dir mein Programmierstil nicht passt, hat hier nichts zu suchen...
Alles was du hier geschrieben hast bezieht sich auf den mehr oder weniger nicht vorhandenen Programmierstil in dem Code...
Weil ich mir den code ja eigentlich (aus allgemeinem Interesse heraus) durchaus ansehen wollte. Aber derart tiefes nesting/lange Zeilen entziehen sich der sinnvollen Darstellung im Editor, und damit letztendlich auch meiner Anschauung..
So manches könnte man in Funktionen auslagern, speziell der dispatcher würde dadurch sehr viel verständlicher.
Zum Beispiel den unless(::NO_CLEANUP) Block einfach in eine Funktion auslagern.
Es könnte so einfach aussehen.
Code:
sub run {
local $SIG{TERM} = sub { threads->exit(0) };
local $SIG{KILL} = sub { threads->exit(2) };
local $_;
while (1) {
lock(@::thr);
lock(@::thr_in);
lock(@::thr_out);
unless(::NO_CLEANUP) {
cleanup();
}
dispatch_commands();
}
}
Die dahinterstehenden Funktionen wären eventuell noch genauso umfangreich, aber zumindest hätte man auf einen Blick, was im Hauptteil (ie: der Endlos-Schleife) passiert.
Zitat:
Was hast du ueberhaupt gegen den Aufruf ohne Klammern?
Hab ich doch geschrieben: das sieht halt schon arg kryptisch aus. Aber ist ne reine Stil-Frage, durchaus.
Zitat:
Ich weiss was das Semikolon bedeutet -.-
Es ist ein ueberbleibsel aus ::v($index, @args);
Sorry dann. (Ist ja noch nicht zu spät es zu entfernen, wenns eh nicht mehr gebraucht wird..)
Zitat:
Perl geht nach dem Motto TIMTOWDI. Warum also kuenstlich wieder so viele Vorschriften machen? Warum darf ich meine Funktionen nicht ohne Klammern aufrufen? Warum darf ich keine Zeilen > 80 Zeichen verwenden? Warum muss mein Code 5.8.8-Kompatibel sein? Warum...
perl 5.8.8 weil mehr Leute, Zeilen < 80 weil mehr Verständnis. Ganz neutral.
Ich würde schätzen, dass sich deine Verwirrungen (und die bizarren bugs) fast von alleine lösen sollten, sobald du das interface etwas aufgeräumt hast..
Zitat:
Dann kommentiere die Zeilen doch einfach aus... Sind fuer den Programmablauf sowieso irrelevant.
Konnt ich ja schlecht wissen..
Zitat:
Generell machst du auf mich hier einen sehr eingebildeten Eindruck, ohne dich jetzt angreifen zu wollen.
Den Eindruck mach ich auch anderswo (also nicht nur im hiesigen "hello world"-Ghetto). Das liegt daran, dass ich sehr arrogant bin.
Zitat:
Aber die Tatsache dass dir mein Programmierstil nicht passt, hat hier nichts zu suchen
Ganz fehl am Platz finde ich meine (nicht gänzlich destruktive) Kritik eigentlich nicht.
Und ich bin mir sehr sicher, dass dir der Unterschied zwischen reinem Stilgenörgel und Kritik an der Verständlichkeit des Programmflusses klar ist.
Ich meine, warum überhaupt packages verwenden um dann letztlich doch alles in eine EierlegendeWollmilch-run-Funktion zu packen?
Conway-Nazis gibts sicherlich schlimmere als mich.
Und noch etwas "richtiges" Ontopic zun Schluss: bei "list" gehen seltsame Dinge vor sich. Wenn man etwas wartet, kommt der "timestamp", wenn man sich beeilt kommt (manchmal ) 127.0.0.1. Wenn ich einen Client starte und dann noch einen zweiten und vom zweiten dann list macht, kommt 127.0.0.1.
Generell ist beim zweiten "list" Kommando aber immer Sense. (Danach kommt garnix mehr bei clients an und dein server meckert über uninitialised irgendwas.)
Dann mal viel Spaß beim debuggen. (;
Ich hab' den Code mal mehr deinen Vorstellungen angepasst, der Cleanup will aber immer noch nicht so wie er soll...
code
Code:
#!/usr/bin/env perl
package main;
use strict;
use warnings FATAL => 'all';
use threads;
use threads::shared;
use IO::Socket::INET;
use Time::HiRes qw/usleep gettimeofday tv_interval/;
use constant {
NO_CLEANUP => 1,
SHOW_DEBUG => 1,
SERVER_ADDR => 'localhost',
SERVER_PORT => 3333,
CLIENT_TIMEOUT => 5,
};
sub debug {
if( ::SHOW_DEBUG ) {
local $_ = join '', @_, "\n";
s/\n+$/\n/g;
print STDERR '[', scalar(localtime), '] ', $_;
}
}
local $| = 1;
my $cid = 0;
my @thr :shared = ();
### DEFINE SIGNAL HANDLERS
$SIG{CHLD} = 'IGNORE'; # thread tries to read from a closed socket
$SIG{TERM} = sub{ exit 1 };
$SIG{KILL} = sub{ exit 2 };
### BIND TO SOCKET
my $msock = new IO::Socket::INET(
Listen => SOMAXCONN,
Type => SOCK_STREAM,
Proto => 'tcp',
LocalPort => ::SERVER_PORT,
LocalAddr => ::SERVER_ADDR,
ReuseAddr => 1,
) or die "Master socket error: $!\n";
debug 'Server listening on ', $msock->sockhost, ':', $msock->sockport;
### START DISPATCHER
threads->new( \&dispatcher )->detach;
debug 'Dispatcher started';
### HANDLE CLIENT CONNECTIONS
while( my $csock = $msock -> accept ) {
debug 'Client connected: ', $csock->sockhost, ':',
$csock->sockport;
$csock->autoflush;
{
lock @thr;
my @info; share(@info);
my @in; share(@in);
my @out; share(@out);
@info = (
join('.', gettimeofday),
$csock->peerhost,
$csock->peerport,
\@in,
\@out,
join('.', gettimeofday),
);
$thr[$cid] = \@info;
$info[6] = threads->new(\&socketReader, $cid, $csock)->tid;
$info[7] = threads->new(\&socketWriter, $cid, $csock)->tid;
}
$cid++;
usleep 250;
}
### KILL REMAINING THREADS
foreach( threads->list ) {
$_->kill('KILL')
if $_->is_running;
$_->detach;
}
### DEFINE SUBS ###########################################################
sub socketReader {
my $cid = shift;
my $csock = shift;
$csock =~ /GLOB\((.+)\)/;
debug 'socketReader started: ', $cid, ':', threads->tid, ' / ', $1;
$thr[$cid][9] = 1;
local $SIG{TERM} = sub{ eval{close $csock}; threads->exit(1) };
local $SIG{KILL} = sub{ eval{close $csock}; threads->exit(2) };
local $_;
eval {
while( defined($_ = <$csock>) ) {
{
lock @{$thr[$cid]};
$thr[$cid][5] = join '.', gettimeofday;
$thr[$cid][10] = join '.', gettimeofday;
}
{
lock @{$thr[$cid][3]};
$_ =~ s/[\r\n]//g;
push @{$thr[$cid][3]}, $_;
}
usleep 250;
}
};
my $e = $@;
eval{ close $csock };
threads->exit( $e ? 3 : 0 );
}
sub socketWriter {
my $cid = shift;
my $csock = shift;
$csock =~ /GLOB\((.+)\)/;
debug 'socketWriter started: ', $cid, ':', threads->tid, ' / ', $1;
$thr[$cid][8] = 1;
local $SIG{TERM} = sub{ eval{close $csock}; threads->exit(1) };
local $SIG{KILL} = sub{ eval{close $csock}; threads->exit(2) };
local $_;
eval {
while( usleep 250 ) {
if( $#{$thr[$cid][4]} != -1 ) {
my $out;
{
lock @{$thr[$cid][4]};
$out = shift @{$thr[$cid][4]};
}
if( defined $out && $out ne '' ) {
$out =~ s/\r\n/\n/;
$out .= "\n" unless $out =~ /\n$/;
print $csock $out;
}
}
}
};
my $e = $@;
eval{ close $csock };
threads->exit( $e ? 3 : 0 );
}
sub dispatchCommands (\%) {
my $tbl = shift;
for my $cid ( 0 .. $#thr ) {
if( exists $thr[$cid] ) {
if( $#{$thr[$cid][3]} != -1 ) {
lock @{$thr[$cid][3]};
my($cmd, $args) = split(' ', shift @{$thr[$cid][3]}, 2);
if( defined $cmd && $cmd ne ''
&& $cmd =~ /^[a-z]+$/
&& exists $tbl->{$cmd} )
{
eval{ $tbl->{$cmd}{cmd}->($cid, $args) };
$tbl->{'ERROR'}->($cid, $@, $cmd, $args)
if $@;
} else {
$tbl->{DEFAULT}->($cid, $cmd);
}
}
}
}
}
sub killThread {
my($cid, $tid) = @_;
if( exists $thr[$cid][$tid]
&& defined $thr[$cid][$tid]
&& $thr[$cid][$tid] =~ /^\d+$/
&& defined threads->object($thr[$cid][$tid]) )
{
threads->object($thr[$cid][$tid])->kill('KILL')
}
}
sub cleanupThreads {
while( usleep 1000 ) {
for my $cid ( 0 .. $#thr ) {
if( exists $thr[$cid] ) {
### remove invalid
unless( ref $thr[$cid] eq 'ARRAY' ) {
lock @thr;
delete $thr[$cid];
debug " *** removing invalid: $cid";
} else {
### remove failed
unless( defined $thr[$cid][8]
&& defined $thr[$cid][9]
&& defined $thr[$cid][10] )
{
if( tv_interval([$thr[$cid][0]]) > 3 ) {
killThread($cid, 6);
killThread($cid, 7);
lock @thr;
lock @{$thr[$cid]};
delete $thr[$cid];
debug " *** removing failed: $cid";
}
} else {
### remove timed out
unless( tv_interval([$thr[$cid][10]])
< CLIENT_TIMEOUT )
{
killThread($cid, 6);
killThread($cid, 7);
lock @thr;
lock @{$thr[$cid]};
delete $thr[$cid];
debug " *** removing timed out: $cid";
}
}
}
}
}
}
}
sub dispatcher {
my %table;
$table{DEFAULT} = sub {
my $cid = shift;
my($cmd, $args) = split ' ', shift, 2;
lock @{$thr[$cid][4]};
push @{$thr[$cid][4]}, " >>> unknown command &" . $cmd . "(" .
(defined $args ? $args : '') . ")";
};
$table{ERROR} = sub {
my $cid = shift;
lock @{$thr[$cid][4]};
push @{$thr[$cid][4]}, " >>> error executing command &" .
$_[1] . '(' . (defined $_[2] ? $_[2] : ''). ') : ' . $_[0];
};
$table{'help'} = {
cmd => sub {
my $cid = shift;
my $command = shift;
lock @{$thr[$cid][4]};
if( defined $command ) {
if( exists $table{$command} ) {
if( ref $table{$command} eq 'HASH'
&& exists $table{$command}{help} )
{
local $_ = $table{$command}{help};
$_ =~ s/\n+/\n /g;
push @{$thr[$cid][4]}, " *** $_\n";
} else {
push @{$thr[$cid][4]}, " *** no help availible";
}
} else {
push @{$thr[$cid][4]}, " *** no such command";
}
} else {
my $help = '';
foreach( sort keys %table ) {
unless( $_ =~ /^DEFAULT|ERROR|help$/ ) {
$help .= " $_\n";
}
}
push @{$thr[$cid][4]}, " *** availible commands:\n" . $help;
}
}
};
$table{'echo'} = {
help => "echo STRING back to sender:\n".
" echo STRING\n",
cmd => sub {
my $cid = shift;
my $string = shift;
lock @{$thr[$cid][4]};
if( defined $string ) {
push @{$thr[$cid][4]}, " *** $string";
} else {
push @{$thr[$cid][4]}, " *** not enough arguments";
}
},
};
$table{'time'} = {
help => "display current servertime:\n".
" time [hires]\n",
cmd => sub {
my $cid = shift;
my $arg = shift;
lock @{$thr[$cid][4]};
if( defined $arg ) {
if( $arg eq 'hires' ) {
push @{$thr[$cid][4]}, " >>> " .
join('.', gettimeofday);
} else {
push @{$thr[$cid][4]}, " >>> inalid argument '$arg'";
}
} else {
push @{$thr[$cid][4]}, " >>> " . time
}
}
};
$table{'date'} = {
help => "display current serverdate:\n".
" date\n",
cmd => sub {
my $cid = shift;
lock @{$thr[$cid][4]};
push @{$thr[$cid][4]}, " >>> " . localtime;
}
};
$table{'send'} = {
help => "send STRING to all connected clients:\n".
" send STRING\n",
cmd => sub {
my $cid = shift;
my $string = shift;
lock @{$thr[$cid][4]};
if( defined $string && $string ne '' ) {
push @{$thr[$cid][4]}, " <<<[*] : $string";
for my $id ( 0 .. $#thr ) {
if( $id != $cid && exists $thr[$id] ) {
lock @{$thr[$id][4]};
push @{$thr[$id][4]}, " >>> [$cid] : $string";
}
}
} else {
push @{$thr[$cid][4]}, " *** not enough arguments";
}
}
};
$table{'whisper'} = {
help => "send STRING to CLIENT:\n".
" whisper CLIENT STRING\n",
cmd => sub {
my $cid = shift;
my($id, $string) = split ' ', shift, 2;
lock @{$thr[$cid][4]};
if( defined $id && defined $string ) {
if( $id =~ /^\d+$/ ) {
if( exists $thr[$id] ) {
push @{$thr[$cid][4]}, " <-- [$id] : $string";
lock @{$thr[$id][4]};
push @{$thr[$id][4]}, " --> [$cid] : $string";
} else {
push @{$thr[$cid][4]},
" *** client $id does not exists";
}
} else {
push @{$thr[$cid][4]}, " *** invalid id";
}
} else {
push @{$thr[$cid][4]}, " *** not enough arguments";
}
}
};
$table{'list'} = {
help => "list currently connectet clients:\n".
" list",
cmd => sub {
my $cid = shift;
lock @{$thr[$cid][4]};
my $list = '';
for my $cid ( 0 .. $#thr ) {
if( exists $thr[$cid] ) {
lock(@{$thr[$cid]});
$list .= " $cid : $thr[$cid][1]:$thr[$cid][2]\n";
}
}
push @{$thr[$cid][4]}, " *** Connected clients:\n" . $list;
}
};
$table{'info'} = {
help => "print information about a client:\n".
" info CLIENT\n",
cmd => sub {
my $cid = shift;
my $id = shift;
lock @{$thr[$cid][4]};
if( defined $id ) {
if( $id =~ /^\d+$/ ) {
if( exists $thr[$id] ) {
push @{$thr[$cid][4]},
" *** Information on client $id:\n".
" connected: $thr[$id][0]\n".
" idle: " .
(defined $thr[$id][10]
? tv_interval([$thr[$id][10]])
: ' [no action yet] '
) . "\n" .
" address: $thr[$id][1]\n".
" port: $thr[$id][2]\n";
} else {
push @{$thr[$cid][4]},
" *** client $id does not exists";
}
} else {
push @{$thr[$cid][4]}, " *** invalid id";
}
} else {
push @{$thr[$cid][4]}, " *** not enough arguments";
}
}
};
while( usleep 250 ) {
cleanupThreads()
unless ::NO_CLEANUP;
dispatchCommands( %table );
}
}
__END__
Ich vermute mal dass ich mich in der 1. Version irgendwo bei einer Arrayref vertan habe, wieso der Cleanup nicht funktioniert bleibt mir allerdings immernoch ein Raetsel...
12.02.09, 21:33
perl threads::shared - diverse Probleme mit "shared" variablen 
Linear-Darstellung
Ähnliche Themen 
