######## init script ##############################
#!/bin/sh
./tk-shmem red &
./tk-shmem green &
./tk-shmem blue &
exit;
### End of init shell script######################

#### tk-shmem ###################################
####################################################
#!/usr/bin/perl
use warnings;
use strict;
use IPC::SysV qw(IPC_STAT IPC_PRIVATE IPC_CREAT IPC_EXCL
                       S_IRUSR S_IWUSR IPC_RMID S_IRWXU);
use Tk;

# USAGE: first run it with 'red' as $ARGV[1], which inits it all 
# THEN : start 2 more instances with 'green' then 'blue' as $ARGV[1] 

if(scalar @ARGV != 1){
   print "Usage: tk-shmem red (or green or blue)\n";exit }

#initial_pos delta $x $y $dx $dy,$ipc_key 
my %pos = (
  'red'   => {
            x => 0,
            y => 0,
          'key' => 1234,
           },
  'green'   => {
            x => 50,
            y => 0,
          'key' => 1235,
           },
  'blue'   => {
            x => 100,
            y => 0,
          'key' => 1236,
           },
);

my $numclients = scalar keys %pos; #1 for self 
my $identity = shift;  #first red, then green and blue 
my $dx = -$pos{$identity}{'x'};  #keep motion 0,0 based 
my $dy = 0;
my $go = 1;
my $segment_bytes = $numclients * 10; #10 bytes per client   

my %shmids;
my $segment_size;

if($identity eq 'red'){
   foreach my $color( keys %pos){
    ( $shmids{$color},$segment_size) = &init_m($pos{$color}{'key'}, $s
+egment_bytes);
    print "$color shmid-> $shmids{$color}\tsize-> $segment_size\n";
    }
}else{
     foreach my $color( keys %pos){
       $shmids{$color} = shmget($pos{$color}{'key'},0,0);
       $segment_size = &size_m( $shmids{$color} );
       print "$color shmid-> $shmids{$color}\tsize-> $segment_size\n";
     }
}

my $mw = tkinit;
$mw->configure(-title=>"---- $identity control ----");

my $screenloc = '300x340+'.-$dx.'+'.-$dx;
$mw->geometry($screenloc);

my $canvas = $mw->Canvas(-width => 300,
                       -height => 300,
                       -bg => 'black',
                       )->pack;

foreach my $color(reverse sort keys %pos){
  $canvas->createRectangle( $pos{$color}{'x'},
                            $pos{$color}{'y'},
                            $pos{$color}{'x'} + 50,
                            $pos{$color}{'y'} + 60,
                              -fill => $color,
                              -tags => [ $color ],
                           );
}

$canvas->bind($identity, '<1>', sub {&mobileStart();});
$canvas->bind($identity, '<B1-Motion>', sub {&mobileMove();});
$canvas->bind($identity, '<ButtonRelease>', sub {&mobileStop();});

if($identity eq 'red'){
  foreach my $color(reverse sort keys %pos){
    my $initstr = '';
    $initstr .=  $pos{$color}{'x'}.'^'.$pos{$color}{'y'};
    &write_m($shmids{$color}, $initstr);
    print $shmids{$color},' ',$initstr,"\n";
   }
}

my $repeater = $mw->repeat(100, sub{ &read_m });

my $closebutton = $mw->Button(-text => 'Exit',
                    -command => sub{ &close_m() })->pack;

$mw->protocol('WM_DELETE_WINDOW' => sub { &close_m() });
MainLoop;

############################################################# 
sub slaveMove {

  foreach my $color (keys %pos){
    next if $color eq $identity;
    my ($dx,$dy);
    my ($x0,$y0,$x1,$y1) = $canvas->coords( $canvas->find('withtag', $
+color ));

    $dx = $pos{$color}{'x'}  - $x0;
    $dy = $pos{$color}{'y'}  - $y0;

   $canvas->move( $canvas->find('withtag', $color ),
                                $dx,$dy  );
    }
}
################################################################# 
sub mobileStart {
       $canvas->configure(-cursor => 'top_left_corner');
     }

################################################################      
+           
sub mobileMove {
   my $ev = $canvas->XEvent;
   $canvas->move('current', $ev->x + $dx, $ev->y +$dy);
   ($dx, $dy) = (0 - $ev->x, 0 - $ev->y);
   my $string = -$dx.'^'.-$dy;
   &write_m($shmids{$identity}, $string);
 }
##############################################################        
+   

sub mobileStop{
    $canvas->configure(-cursor => 'top_left_arrow');
    &mobileMove;
}

############################################################### 
sub init_m(){
  my ($key,$segment_bytes) = @_;
  # Allocate a shared memory segment.  
  my $segment_id = shmget ($key, $segment_bytes,
                       IPC_CREAT | IPC_EXCL | S_IRUSR | S_IWUSR);

  # Verify the segment's size. 
  my $shmbuffer = '';
  shmctl ($segment_id, IPC_STAT, $shmbuffer);
  my @mdata = unpack("i*",$shmbuffer);
return($segment_id, $mdata[9] );
}

############################################################## 
sub write_m{
   # Write a string to the shared memory segment. 
   my( $shmid, $message) = @_;
   shmwrite($shmid , $message, 0, $segment_size ) || die "$!";
   return 0;
  }
################################################################# 
sub read_m{
      foreach my $color( keys %shmids){
        next if $color eq $identity;
        my $buff;

        if( shmread($shmids{$color}, $buff, 0, $segment_size ) ){
        $buff =~ s/\0//g;   # it's padded with nulls \0  
        ( $pos{$color}{'x'}, $pos{$color}{'y'} ) = split(/\^/,$buff);
        &slaveMove();
          }else{ &close_m }
     }
 }
############################################################### 
sub size_m{
  my $segment_id = shift;
  my $shmbuffer = '';
  shmctl ($segment_id, IPC_STAT, $shmbuffer);
  my @mdata = unpack("i*",$shmbuffer);
  print "segment size: ", $mdata[9], "\n";
  return($mdata[9]);
}
############################################################## 
sub close_m{
  # Deallocate the shared memory segments. 
   $repeater->cancel;
   $go = 0;
   if($identity eq 'red'){
        foreach my $color( keys %pos){
           shmctl ($shmids{$color}, IPC_RMID, 0);
         }
   }
exit;
}
__END__
[download]