Beefy Boxes and Bandwidth Generously Provided by pair Networks
XP is just a number
 
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??

#!/usr/bin/perl use strict; use warnings; use feature qw/say state/; #declare alphabet values a .. z , as 0 .. 25 my @indexofchr = 'a' .. 'z'; say "index of standard 1:1 mapping\n\n", map "\t$indexofchr[$_] : $_\n +", (9,0,15,7); # j : 9 # a : 0 # p : 15 # h : 7 # assign random unique values for each letter of alphabet. # to emulate a dataset construction my %table = map { $_ => 1 } 'a' .. 'z' ; %table = map { state $c=0; $_ => $c++ } keys %table ; say "new hashtable of rnd:1 mapping\n\n", map "\t$_ : $table{$_}\n", q +w( j a p h ); # j : $indexofchr[ rnd(0-25) ] # a : $indexofchr[ rnd(0-25) '-1' ] # p : $indexofchr[ rnd(0-25) '-2' ] # h : $indexofchr[ rnd(0-25) '-3' ] # at this stage of the dataset construction we have constructed a stra +ightforward string to number hash; # look up unique string 'j' to get numberid; # print 'string please: '; stdin<>; untaint; chomp; etc my $lookupSTRID = 'j'; say "the number retrieved for STRID j is:"; say "$table{ $lookupSTRID }"; # what we need to do now is complete the reverse look up. # This is proposed on the requirement that # the values, both numeric and alphabetic, are unique. # lets say for the sake of example the randomization of the letters # has created j to be = 16; # and s to be = 9; # This gives us an example that the key character j returns the number + 16. # while at the same time the numeric value nine (the key chr j) return +s s. # further the KEY of s will also contain a scalar NAME with an underly +ing value and so on through all the characters. # if the scalar NAME of the value under the key of j is $s and the und +erlying value is 16 then this represents a # compression in that we have encoded both the KEY and the VALUE of th +e HASH to represent both a unique string and number. # effectively reducing the overhead by half as we only need to create +one hash. # However in practice, while I suggest there may be a good compression + factor in the smaller values, # the larger values may still require both lookups to be added into th +e hash. # Other drawbacks to this approach are; # This may incur extra computation to convert numbers into the keys. # And also that each character is using 128/256 bits where only 24+2 a +re required (or 32-4) # though that optimisation could be forged under requirement. By creat +ing say, a custom character set. # so to example on the sample: # in the above example there is a straight forward 1:1 randomized mapp +ing, # all key NAMES/values will numerically identify all scalar NAME/value +s. # now embelish the keys / values with the reverse lookup information foreach(keys %table){ { no strict 'refs'; $table{$_} = $*{'main::'.$indexofchr[$table{$_}]} = $table{$_} ; } } say "chrs added hashtable\n\n", map "\t$_ : $*{'main::'.$_}\n", qw( j +a p h ); # so we look up the unique number nine and we then see that this relat +es to the value variable name # that is the actual scalar variable NAME held in the hash, not the un +derlying scalar value # look up unique number 'nine' to get string; # print 'number please: '; stdin<>; untaint; chomp; etc my $lookupNOID = 9; say "the string retrieved for NOID 9 is:"; say "$table{ $indexofchr[$lookupNOID] }"; # Ah, But we got a number. This would be fine if we were looking up th +e uniquethe wrong thing here, we r have not actually integrated the # but actually the variables NAME is associated wiht the key character + value # during construction the hash is constructed as the data comes in. #%table = map { $_ => @indexofchr[$_] } keys %table ; #say "new hashtable of rnd:1 mapping\n\n", map "\t$_ : $table{$_}\n", +qw( j a p h ); # j : $indexofchr[ rnd(0-25) ] # a : $indexofchr[ rnd(0-25) '-1' ] # p : $indexofchr[ rnd(0-25) '-2' ] # h : $indexofchr[ rnd(0-25) '-3' ] # In production the code would map the unique integers (as a function +of the value of key characters converted to numerical values) # to the value variable NAME. # key a=0, b=1, c=2, ..., z=25; The value variable NAME would differ d +epending on the constructed dataset. # lookup unique number 0 # Now we have all the strings a .. z mapped to a number held by the va +lue variable # #The relationship of the key to the value is only that the value varia +ble name holds only the value of the key. # to find the string by number we lookup the letter key represented by + the number to get the string # the string is the value variable name #$table{bar} = ( $foo = 4_001 ) ; #say $$word; exit 0;

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 contemplating the Monastery: (4)
As of 2015-02-02 00:13 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    On my keyboard, Caps lock is:








    Results (16 votes), past polls