Beefy Boxes and Bandwidth Generously Provided by pair Networks
We don't bite newbies here... much
 
PerlMonks  

Don Coyote's scratchpad

by Don Coyote (Monk)
on Jul 01, 2010 at 17:29 UTC ( #847567=scratchpad: print w/ replies, xml ) Need Help??

the - using the word lasoosely - working, code. It runs on strawberry c5.10.1

Hi waytoperl

I would side with Discipulus here and abduct that your problem is in regard to simultaneously printing the output into multiple filehandles, or multiplexing.

For me it seemed clear that using the single form of perl built in select would be necessary to achieve simple multiplexing. However, I managed to rework the code around the perl built in pipe function. Thank Strawberry for perldoc.

Essentially, once you have selected a filehandle, the filehandle_special-variables are operational on that filehandle

Any regular output run in a perlfunc:system call will go to that output filehandle, but there, as in the code here, any redirections within the external script, will behave as scripted.

the pipe fork combo sets up a situation where you may select the output filehandle to only print to the output, or the pipe $writer indirect filehandle, to print to both (or as many as you like) at the same time.

Best not to redirect 0,1,2 unless you understand it well. Even though I have done so here, I am very confident there are better ways. Discipulus' link to log4Perl premise is definetly worth another look.

#!/usr/bin/perl -w use strict; use feature qw{ say }; use File::Spec::Functions qw{ catfile }; use Fcntl; use IO::Handle; #use vars qw{*spfh *pipe_sub}; # special Filehandle variables, # operate on currently selected fh $|++; open my $output, '>', catfile( qw( . output.txt ) ) or die q{ output open fail },$!; my $original_selected_default_output = select $output; $|++; select $original_selected_default_output; #RUN4: { #last RUN4; #comment out on run4 my $reader = IO::Handle->new(); my $writer = IO::Handle->new(); (select($_),$|++) foreach ($reader,$writer,'STDOUT'); pipe($reader,$writer) or die "not today $!"; my $pid = fork(); if( $pid == 0 ){ close $writer; open my $stdout, '>&', 'STDOUT' or die 'aaaarrrggh, so close',$!; + my @filehandles = ( $stdout, $output ); say( 'finely from reader' ) foreach( $stdout, $output ); while(my $l = <$reader>){ foreach my $fh ( @filehandles ){ say { $fh } 'from ',$l, ' reader'; } }continue{} say( 'finely from reader' ) foreach( $stdout, $output ); select $original_selected_default_output ; close $reader; exit 0; }elsif($pid){ close $reader; }else{ die "sporked $!" } # close STDOUT; # open STDOUT, '>&', $writer or die "horribly: $!"; # sub pipe_sub { # open my $tea, '<', \ $pipe_sub or die 'no open t',$! +; # return sub { #do { # #}; # }; # } # no strict q|refs|; # open my $spfh , '<', &pipe_sub or die 'horribly: '.$!; # die $@ if $@; #} # select new default output, and save existing default for restoration +. # select( (my $original_selected_default_output = select( $output ), $ +|=1 )[0]); #my $original_selected_default_output = select $output; #run4 #$|++; # ty Discipulus :) select $output; # says to output.txt say localtime(time),q{ All I need to say is use feature }; select $writer; # says to both # restore default to previous and says to terminal say localtime(time),q{ using say is straightforward for simple outputs + }; close $writer; select $original_selected_default_output or die "not working $!"; #select 'STDOUT'; sleep 1; say localtime(time),q{ snoozing}; say 'My only Friend'; exit 0;

Hi waytoperl, good question, but...

You have not explained clearly the output you expect. Describing what output you expect and where in a little more detail and you may get a better answer.

I would side with Discipulus here and abduct that your problem is in regard to simultaneously printing the output into multiple filehandles, or multiplexing.

Using perl built in select IO::SelectA builtin module providing an object interface to the built-in select function. This will update the default file ($_ in print;) which file handles and variables operate upon by default.

Now you have selected the default filehandle, you then run another script. If that script redirects output itself, you defeat the purpose of redirecting in your primary script.

Best not to redirect 0,1,2 unless you understand this sentence.

From here your solution is to ensure your script is printing where you want it to. Or, import the script into the running program by require-ing

I would suggest using select
#!/usr/bin/perl -w use strict; use feature qw{ say }; use File::Spec::Functions qw{ catfile }; $|++; open my $output, '>', catfile( qw( . output.txt ) ) or die q{ output open fail },$!; # select new default output, and save existing default for restoration +. # select( (my $original_selected_default_output = select( $output ), $ +|=1 )[0]); my $original_selected_default_output = select( $output ); #$|++; # ty Discipulus :) # says to output.txt say localtime(time),q{ All I need to say is use feature }; # restore default to previous and says to terminal select( $original_selected_default_output ); say localtime(time),q{ using say is straightforward for simple outputs + }; sleep 1; say localtime(time),q{ snoozing}; #but now what if your program redirects? my $v = q{ package heresjustanotherpackagehacker; use strict; use warnings; use Carp qw/:DEFAULT/; use File::Spec::Functions qw/catfile/; #use Exporter qw{import}; select(undef,undef,undef,2); say localtime(time),q{ Not to be confused with the four argument form +of select.}; # now redirect inside program open my $output2, '>', catfile( 'C:', 'Documents and Settings', 'Admi +nistrator', 'Desktop', 'output2.txt' ) or croak q{ output2 open fail },$!; my $old_output = select( $output2 ); $|++; # says to output2.txt ? say localtime(time),q{ says to output2 }; # restore default to previous and says to terminal select( $old_output ); say localtime(time),q{ using say is simple for straightforward output +}; my $modules_need_importing++ unless my $but_features_do_not_qm; }; # comment out the eval $v or require line # on run 2 and 1 respectively eval $v; die 'hjaph',$@ if $@; #so lets put that into a script which we call with require; #require 'heresjustanotherscripthacker.pl'; die 'hjash ',$@ if $@; exit 0; __END__ #heresjustanotherscripthacker.pl #slightly modified to direct out to output3 #and not a package #!/usr/bin/perl -w use strict; use Carp qw/:DEFAULT/; use File::Spec::Functions qw/catfile/; use feature qw{say}; #use Exporter qw{import}; select(undef,undef,undef,2); say localtime(time),q{ we are not redirected in the script}; # now redirect inside program open my $output3, '>', catfile( 'C:', 'Documents and Settings', 'Admi +nistrator', 'Desktop', 'output3.txt' ) or croak q{ output3 open fail },$!; my $old_output = select( $output3 ); $|++; # says to output3.txt ? say localtime(time),q{ says to script output3 }; # restore default to previous and says to terminal select( $old_output ); say localtime(time),q{ simply using say is still straightforward for o +utput }; my $modules_need_importing++ unless my $so_do_features; exit 0;
IO::Prompter Term::Cap source

Hi Thanos1983

I have been looking at your server code, as I am becoming more familiar with sockets. The client code helped greatly.

Alarming lack of localised lexicals...
(our) $newline = "\n" ...
yada, yada, yada

Changing up the $readable_handles var may help. The IO::Select constructor returns a select object, which accesses the state of all the handles, whether they be Readable, Writeable, or Exceptions. Also the constructor auto adds any handles passed in.

# $readable_handles = Select::IO->new(); # $readable_handles->add($server_sock); $select_object = Select::IO->new($server_sock);

The select::IO object extends the capabilities of the select function to act upon not only one, but stored arrays of, filehandles.

Given select returns an indication of whether the filehandle is ready to be read from or written to,... ? fcntl block within a local scope within which can_write is called on the select object again ?

The Example in the IO::Select documentation shows the while argument can actually be the call to read the ready select.

#while(1){ while(@readables = $select_object->can_read){ foreach my $sock ( }

using the correct equality operator ?

# if( $sck eq $sock ){} if( $sck == $sock ){}

wtf - recommend a friend.

else { # wtf part a push( @clients , $text[1] ); #--> --^ print Dumper(\@clients); $trans = "OK"; $client_data = &send($trans); print "Second send: ".$client_data."\n"; } } # End of if ($text[0] eq "NICK") elsif ($text[0] eq "MSG") { if (length($text[1]) > MAXBYTES) { $trans = "".$error." Please remember that message limit is + ".MAXBYTES.""; $client_data = &send($trans); print "In case of message over ".MAXBYTES." send: ".$clien +t_data."\n"; } else { print "Second receive: ".$text[1]."\n"; print "This is \$sock: ".$sock."\n"; # Get all client(s) socket(s) my @sockets = $readable_handles->can_write(); #my $count = $readable_handles->count(); # wtf part b # for as many sockets that are readable, take the message with the ind +ex of this this number, from the message queue and replace the curren +t #hashed socket queue with it. # that is, if 5 clients then each client will continue to #recieve the + fifth messages from the message queue. #or at least teh log will only record that, depending on #how the mess +age is processed. for ($_ = 0; $_ < @sockets; $_++) { $hash{$sock} = $clients[$_]; } # or $hash{$sock} = $clients[ scalar @{$select_object->can_write()} ]

so you see - until you get your new buddy to sign in, you dont get to see the next message anyone sent. Also - you only get to say one thing ever.?

ok I think I can see what you are trying to do now.

I cleaned up the server code a bit, including accessing the select 3 x ref to array in a ref to a array. But I tried to clear the fork out of the client (i am on wins rigth now) but that went wrong. so, so far I have...

#!/usr/bin/perl use utf8; use strict; use warnings; use IO::Select; use Data::Dumper; use IO::Socket::INET; # Non-blocking I/O concept. use constant ARGUMENTS => scalar 1; use constant NICKNAME => scalar 12; use constant MAXBYTES => scalar 255; # flush memory after every initialization $| = 1; my $error = "ERROR"; my %hash = (); # global variable my ( $client_data , $buf , $sock , $msg , $new_sock , $trans , $reada +ble_handles , $client , $port ); unless (@ARGV == ARGUMENTS) { print "\nPlease only ARGUMENTS input!\n"; print "Correct Syntax: perl $0 IP:PORT (e.g. 127.0.0.1:5000)\n"; exit(); } my $tmpv = $ARGV[0]; # User message IP:PORT #print "$ARGV[0] \n"; ( my ( $inputip, $inputport ) = ( $ARGV[0] =~ m/^( # $1 $inputip (?: #non-capturing \d{1,3}\. #1-3 digits followed by stop ){3} # x3 \d{1,3} #last 1-3 digit of ip address ) : # colon (\d+) # $2 $inputport $/x ) ); # endmatch print "::$inputip:-:$inputport:\n"; my $server_sock = IO::Socket::INET->new( LocalAddr => $inputip, LocalPort => $inputport, Proto => 'tcp', Listen => SOMAXCONN, Reuse => 1 ) or die "Could not connect: $!"; print "\n[Server $0 accepting clients at IP: $inputip and PORT: $inp +utport.]\n"; # $readable_handles = IO::Select->new(); my $select_object = IO::Select->new($server_sock); while (1) { my @readables = IO::Select->select($select_object, undef, unde +f, 0) ; foreach $sock ( @{ $readables[0] } ) { # Check if sock is the same with server (e.g. 5000) # if same (new client) accept client socket if ($sock == $server_sock) { $new_sock = $sock->accept() or die sprintf "ERROR (%d)(%s)(%d)(%s)", $!,$!,$^E,$^E; $select_object->add($new_sock); $trans = "Hello version"; print { $new_sock } utf8::encode( $trans ); print "First send: $trans\n"; }else{ # read from socket input $buf = <$sock>; my ($msg , $port) = receive($buf); my @text = split(/ / , $msg , 2); # LIMIT = 2 Only the first t +wo gaps split #print Dumper(@text); if ($text[0] eq "NICK") { $hash{$port} = $text[1]; print Dumper(\%hash); #print Dumper(\@names); $trans = "OK"; print { $sock } utf8::encode( $trans ); print "Second send: $trans\n"; }elsif ($text[0] eq "MSG") { print "Second receive: ".$text[1]."\n"; # Get all client(s) socket(s) #my @names = values %hash; my @sockets = $select_object->can_write(); # possible problem ? # none writeable - only 'select'ed readables writeabl +e ?? # (my $new_readable) = IO::Select->select($select_object, undef, + undef, 0); #print Dumper(\@sockets); # Send the same message to client(s) foreach my $sck (@sockets) { my $final = "$text[0] $hash{$port} $text[1] \n"; utf8::encode($final); print { $sck } $final; print "Third send: $final"; #print STDOUT "The following data send to Client(s): ( +\ ".$buf." \)\n"; } }else{ print "Closing client!\n"; # when the client disconnects delete $hash{$port}; $select_object->remove($sock); close($sock); } } # End of else condition ($sock == $server_sock) } # End of foreach $sock @readables } # End of While (1) print "Terminating Server\n"; close $server_sock; getc(); sub send { utf8::encode( $_[0] ); print { $new_sock } $_[0],"\n"; # chomp ($_[0]); # ? chomp encoded line? #print "The following data send to Clients: (\ ".$_[0]." \)\n"; #$client_sock->send($client_packet,MAXBYTES); return $_[0]; } sub receive { #$new_sock->recv($client_data,MAXBYTES); my $datarecieved = utf8::decode($_[0]); # assign $1 to $shortdata may need correcting. my( $shortdata ) = ( m/^(.{0,20})/ =~ $datarecieved ); my( $phost, $pport ) = ( $new_sock->peerhost(), $new_sock->peerpor +t() ); my $fromhostport = "From host: $phost and port: $pport"; print "This:$shortdata\n$fromhostport\n"; return( $datarecieved, $pport ); #(?) should not get here... utf8::encode (qq{ $error, \n } ); $server_sock->send($error); print "Invalid client: $phost : terminating!\n"; $select_object->remove($sock); close($sock); }

previously was this, but the regex didnt work n stuff

#!/usr/bin/perl use utf8; use strict; use warnings; use IO::Select; use Data::Dumper; use IO::Socket::INET; # Non-blocking I/O concept. use constant ARGUMENTS => scalar 1; use constant NICKNAME => scalar 12; use constant MAXBYTES => scalar 255; # flush memory after every initialization $| = 1; #change#4 remove $info assignment to after input validation/untaint. my $error = "ERROR"; my %hash = (); # global variable my ( $client_data , $server_sock , $buf , $sock , $msg , $new_sock , $ +trans , $readable_handles , $client , $port ); #change#1 tidy up if else - only one argument required - the addr:port unless (@ARGV == ARGUMENTS) { print "\nPlease only ".ARGUMENTS." input!\n"; print "\nCorrect Syntax: perl $0 IP:PORT (e.g. 127.0.0.1:5000)\n"; exit(); } #change#2 - unneccessary else block removed. #change#3 - simple regex untaint. #change#(4) directly assign untainted data to ip/port vars. # User message IP:PORT my ( $inputip, $inputport ) = ( $ARGV[0] =~ m/^( #$1 / $inputip (?: #non-capturing \d{1-3}\. #1-3 digits followed by stop ){3} # x 3 \d{1-3} #last 1-3 digit of ip address ) : # colon (\d+) #$2 / $inputport $/x # endmatch ); $server_sock = IO::Socket::INET->new( LocalAddr => $inputip, LocalPort => $inputport, Proto => 'tcp', Listen => SOMAXCONN, Reuse => 1 ) or die "Could not connect: $!"; print "\n[Server $0 accepting clients at IP: ".$inputip." and PORT +: ".$inputport."]\n"; # $readable_handles = IO::Select->new(); $select_object = IO::Select->new($server_sock); while (1) { # ok we are listening ? # hmmm select RBIT by method, on blessed array ref of sockets. ok ? # or returns array ref of rbit set sockets ? # sets or gets readables ? my @readables = @{ IO::Select->select($select_object, undef, undef +, 0) }; foreach $sock ( @readables ) { # Check if sock is the same with server (e.g. 5000) # if same (new client) accept client socket if ($sock == $server_sock) { $new_sock = $sock->accept() or die sprintf "ERROR (%d)(%s)(%d)(%s)", $!,$!,$^E,$^E; $select_object->add($new_sock); $trans = "Hello version\n"; print { $new_sock } utf8::encode( $trans ); print "First send: $trans"; }else{ # read from socket input $buf = <$sock>; my ($msg , $port) = receive($buf); my @text = split(/ / , $msg , 2); # LIMIT = 2 Only the first t +wo gaps split #print Dumper(@text); if ($text[0] eq "NICK") { $hash{$port} = $text[1]; print Dumper(\%hash); #print Dumper(\@names); $trans = "OK\n"; print { $sock } utf8::encode( $trans ); print "Second send: $trans"; }elsif ($text[0] eq "MSG") { print "Second receive: ".$text[1]."\n"; # Get all client(s) socket(s) #my @names = values %hash; my @sockets = $select_object->can_write(); # possible problem ? # none writeable - only 'select'ed readables writeabl +e ?? # (my $new_readable) = IO::Select->select($select_object, undef, + undef, 0); #print Dumper(\@sockets); # Send the same message to client(s) foreach my $sck (@sockets) { my $final = "".$text[0]." ".$hash{$port}." ".$text[1]. +""; utf8::encode($final); print { $sck } "".$final."".$newline.""; print "Third send: ".$final."\n"; #print STDOUT "The following data send to Client(s): ( +\ ".$buf." \)\n"; } }else{ print "Closing client!\n"; # when the client disconnects delete $hash{$port}; $select_object->remove($sock); close($sock); } } # End of else condition ($sock == $server_sock) } # End of foreach new sock } # End of While (1) print "Terminating Server\n"; close $server_sock; getc(); } # End of else @ARGV sub send { utf8::encode( $_[0] ); print { $new_sock } $_[0],"\n"; # chomp ($_[0]); # ? chomp encoded line? #print "The following data send to Clients: (\ ".$_[0]." \)\n"; #$client_sock->send($client_packet,MAXBYTES); return $_[0]; } sub receive { #$new_sock->recv($client_data,MAXBYTES); my $datarecieved = utf8::decode($_[0]); # assign $1 to $shortdata may need correcting. my( $shortdata ) = ( m/^(.{0,20})/ =~ $datarecieved ); my( $phost, $pport ) = ( $new_sock->peerhost(), $new_sock->peerpor +t() ); my $fromhostport = "From host: $phost and port: $pport"; print "This:$shortdata\n$fromhostport\n"; return( $datarecieved, $pport ); #(?) should not get here... utf8::encode (qq{ $error, \n } ); $server_sock->send($error); print "Invalid client: $phost : terminating!\n"; $select_object->remove($sock); close($sock); }

chdir `pwd`

doh!


Log In?
Username:
Password:

What's my password?
Create A New User
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others avoiding work at the Monastery: (6)
As of 2014-12-27 07:40 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    Is guessing a good strategy for surviving in the IT business?





    Results (176 votes), past polls