Beefy Boxes and Bandwidth Generously Provided by pair Networks
Clear questions and runnable code
get the best and fastest answer
 
PerlMonks  

Many-to-One pipe

by Zaxo (Archbishop)
on Aug 07, 2002 at 05:10 UTC ( [id://188235]=CUFP: print w/replies, xml ) Need Help??

I composed this ditty to demonstrate how to let one child process collect data from many client processes forked from the same parent. This was motivated by suaveant's question about speedy local IPC at Fastest way to talk to a perl daemon.

This demo program shows how the file descriptor for the write end of a pipe is duplicated on fork, allowing many processes to share it.

The select... while kill $ppid, 0; line in the client code is there just to keep the kids idle until the parent has departed. That is to avoid waiting or ignoring SIGCHLD. A persistent parent server would need to clean up after the kids.

#!/usr/bin/perl use warnings; use strict; my ( $ppid, $in, $out) = $$; pipe ( $in, $out) or die $!; # "Daemon" { local *STDIN = $in; local $| = 1; my $child; defined( $child = fork) or die $!; last if $child; close $out or die $!; print while <STDIN>; exit 0; } # Spawn some client processess { local *STDOUT = $out; local $| = 1; for my $kid (1..50) { my $child; defined( $child = fork) or die $!; next if $child; close $in; select( undef, undef, undef, .001) while kill $ppid, 0; select( undef, undef, undef, rand(1000)/1000), print 'Child ', $kid, ' pid=', $$, ' message=', 0 | rand 10000, $/ for 1..20; exit 0; } }

Replies are listed 'Best First'.
Re: Many-to-One pipe
by RMGir (Prior) on Aug 07, 2002 at 12:14 UTC
    (Edit: See particle's comment; all that's missing is an '*' on the locals... Removed my questions wondering why it didn't work.)

    Here's a version that works for me. I reduced the limits so it didn't spam quite as much :)

    #!/usr/bin/perl use warnings; use strict; my ( $ppid, $in, $out) = $$; pipe ( $in, $out) or die $!; # "Daemon" { #local STDIN = $in; local $| = 1; my $child; defined( $child = fork) or die $!; last if $child; close $out or die $!; while (<$in>){ print "Parent got: $_"; } exit 0; } # Spawn some client processess { #local STDOUT = $out; select($out); local $| = 1; for my $kid (1..10) { my $child; defined( $child = fork) or die $!; next if $child; close $in; select( undef, undef, undef, .001) while kill $ppid, 0; select( undef, undef, undef, rand(1000)/1000), print 'Child ', $kid, ' pid=', $$, ' message=', 0 | rand 10000, $/ for 1..20; exit 0; } }

    --
    Mike
    (Edit: Added 5.6.1-friendly version of code)
      Hmmm, 5.6.1 doesn't like local STDIN = $in; or local STDOUT = $out;.

      that's because it's missing the sigil... local *STDIN = $in; or local *STDOUT = $out;

      Is that a 5.8 feature? I've never seen that construct before. It'd be nice to have, though!

      this is a standard feature (assuming the syntax is correct.) the first one will fail under 5.008 with the same errors. my correction should work fine under any recent perl.

      ~Particle *accelerates*

Re: Many-to-One pipe
by cmv (Chaplain) on Sep 12, 2014 at 15:17 UTC
    ++zaxo - Wonderfully useful still these many years later!

    I continue to be confused by the select... while kill $ppid, 0; even with the note about it in the description. Can someone elaborate some more to help me understand better?

    Here is my modified version of the original code. I ended up making it more verbose, and added additional code for the parent to manage the children.

    Please feel free to comment or suggest improvements!

    Thanks

    -Craig

    #!/usr/bin/perl use warnings; use strict; use Data::Dumper; $::DEBUG = 1; # 0=off my $DKID; # Daemon kid PID my %CKIDS; # Client kids PIDs # Make a pipe (in/out filehandles are parent's process id)... my ($ppid, $in, $out) = $$; pipe ($in, $out) or die $!; print STDERR "Parent is $ppid\n"; ################## # spawn daemon kid ################## { local $|=1; # Fork daemon child... my $child; defined($child = fork) or die $!; # Parent & kid sort themselves out... if($child) { print STDERR "daemon child is $child\n" if $::DEBUG; $DKID=$child; last; } # Kid code... print STDERR "I am Daemon child $$\n" if $::DEBUG; close $out or die $!; # deamon kid does not write, only reads # Daemon reads input side of pipe, forever... while (<$in>){ #print "Daemon got: $_"; print "."; } exit 0; } ################### # spawn client kids ################### { select($out); local $|=1; # Spawn 10 client kids... for my $kid (1..10) { # Fork kid... my $child; defined($child = fork) or die $!; # Parent & kid sort themselves out... if($child) { # Parent $CKIDS{$child} = $kid; next; # Parent moves on } # Kid code... print STDERR "I am client child $$\n" if $::DEBUG; close $in; # client kid does not read, only writes # Print out messages at random times... select(undef, undef, undef, rand(1000)/1000), print 'Child ', $kid, ' pid=', $$, ' message=', 0 | rand 10000, "\n" for 1..10; exit 0; } } ############# # Manage kids ############# print STDERR "CKIDS DUMP:\n", Dumper(\%CKIDS), "\n" if $::DEBUG; # Watch kids until all are gone... my $ret; while ( ($ret = waitpid(-1, 0)) > 0 ) { # Handle dead kid... print STDERR "\nPARENT: Child ret=$ret status: $?\n" if $::DEBUG; my $exit_value = $? >>8; my $signal_num = $? & 127; my $dumped_core = $? & 128; print STDERR "PARENT: Child exit=$exit_value, sig=$signal_num, core=$dumped_core\n" if $::DEBUG; # Remove from list if client kid... delete($CKIDS{$ret}); print STDERR "CKIDS DUMP:\n", Dumper(\%CKIDS), "\n" if $::DEBUG; # If no more client kids, kill daemon kid... if(scalar(keys(%CKIDS)) <= 0) { # Will repeatadly hit this code if daemon kid doesn't die... print STDERR "All client kids gone, killing daemon kid...\n" i +f $::DEBUG; kill('HUP', $DKID); } } print STDERR "PARENT: All kids gone, exiting\n";

Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?
Node Status?
node history
Node Type: CUFP [id://188235]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this?Last hourOther CB clients
Other Users?
Others admiring the Monastery: (6)
As of 2024-03-28 13:45 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found