## files separated by #== #== weblife-client.pl ################ #!/usr/bin/perl -w use WebLife::System qw(set_debug); use strict; set_debug(debug => ['WebLife::Game::run']); my %args = @ARGV; my $addr = shift @ARGV; $args{'-p'} && $args{'-a'} or die "Usage: $0 -p pos.server.address:port -a " . "address[:port]"; my $sys = WebLife::System->new ( pos_server_addr => $args{'-p'}, address => $args{'-a'} ); $sys->run; exit 0; #== weblife-server.pl #################### #!/usr/bin/perl -w use WebLife::System qw(set_debug); use strict; set_debug(debug => ['WebLife::Game::run']); my %args = @ARGV; $args{'-a'} && $args{'-m'} && $args{'-u'} or die "Usage: $0 -a address:port -m mapsize" . " -u universe size"; my $sys = WebLife::System->new ( is_pos_server => 1, map_size => $args{'-m'}, universe_size => $args{'-u'}, address => $args{'-a'}, ); $sys->run; exit 0; #== WebLife/System.pm ################ package WebLife::System; =head1 WebLife::System Package to run a Game of Life over a P2P network of hosts. Each host i +s responsible for a square of n x n cells. Every n turns, each host communicates its current state with its neighbours. It then calculates n further turns of the game, starting with a larger map of it and all its neighbours, and stripping off one layer of cells each turn in orde +r to arrive at its new state. Example (n=3): Step 1: neighbours send me their state -xx --x --- --- --- --- --- --- --- --- --x --- --x -x- --- --x x-- --- --- --x -xx --- --- -xx --- --- --- Step 2: create larger map -xx--x--- --------- --------- -----x--- --x-x---- --xx----- -----x-xx -------xx --------- Step 3: calculate 3 turns turn 1 (U = state unknown, cells discarded from map) UUUUUUUUU U-------U U-------U U-------U U-x-x---U U-xxx---U U-----xxU U----xxxU UUUUUUUUU turn 2 UUUUUUU U-----U U-----U Ux-x--U Ux-xx-U U-x---U UUUUUUU turn 3 UUUUU U---U U-xxU U-xxU UUUUU Step 4: Send my new state to my neighbours \ | / --- - -xx - -xx / | \ The system is not completely peer-to-peer. Initial positions, neighbour addresses and initial cell maps are provided by a position server. (It is possible to devise algorithms which allow peers to self-organize into a square, but this is rather complex +!) The universe as a whole is also a square of m x m peers. The position server determines the choice of m and n, and can therefore decide how big the Game of Life will be. =head2 Synopsis # join an existing game: my $sys = WebLife::System->new( address => 'my.website.net', pos_server_addr => 'pos.serveraddress.net:4331' ); $sys->run; # create your own game: my $sys = WebLife::System->new( is_pos_server => 1, map_size => 10, universe_size => 5, address => 'my.website.net' ); $sys->run; =cut use strict; use vars qw($SYSTEM @EXPORT_OK); use Exporter; use Carp qw(carp confess); use base qw(Exporter); BEGIN {@EXPORT_OK = qw($SYSTEM debug set_debug);} use WebLife::AddressBook; use WebLife::MessageHandler; use WebLife::Universe; use WebLife::Parser; use WebLife::Game; use WebLife::Transport; use WebLife::PositionServer; use WebLife::Preparer; my $PORT = 4331; =head2 Methods =over 4 =item new WebLife::System->new(%options); WebLife::System->new( address => 'address[:port]', pos_server_addr => 'address:port', ); WebLife::System->new( is_pos_server => 1, map_size => $map_size, universe_size => $univ_size, address => 'address[:port]', ); Creates a new WebLife::System object. Options: =over 8 =item address Internet address where the peer will run, with or without a port numbe +r. If no port number is given, the default will be used (currently 4331). If this option isn't given, the address will be 'localhost' - not much use except for testing. =item pos_server_addr Internet address, including port, of the peer which will act as positi +on server for this peer. The position server will also tell you about you +r initial map, your position, the size of your universe and map, and you +r neighbour addresses and positions. =item is_pos_server Flag to tell the object to be a position server. The default is 0. If this is not set, then the pos_server_addr must be given. =item map_size Integer size of the area of the Game of Life board which will be the responsibility of a single peer. E.g. if map_size is 10, each peer wil +l be responsible for a 10x10 square containing 100 cells. This option is only meaningful if the is_pos_server flag is set. =item universe_size Integer size of the WebLife universe. E.g. if universe_size is 10, the universe will be a 10x10 square requiring 100 peers. This option is only meaningful if the is_pos_server flag is set. Total number of cells in the universe = (universe_size ** 2) * (map_si +ze ** 2) =back =cut sub new { return $SYSTEM if defined $SYSTEM; my $class = shift; my $self = bless {@_}, $class; $SYSTEM = $self; $self->{addressbook} ||= new WebLife::AddressBook; $self->{messagehandler} ||= new WebLife::MessageHandler; $self->{parser} ||= new WebLife::Parser; $self->{preparer} ||= new WebLife::Preparer; $self->{address} ||= 'localhost'; # change to die, later my $port; if ($self->{address} =~ /:(\d+)$/) { $port = $1; } else { $port = $PORT; $self->{address} .= ":$port"; } $self->{transport} ||= new WebLife::Transport($port); if ($self->{is_pos_server}) { die "No map_size defined" unless $self->{map_size}; die "No universe_size defined" unless $self->{universe_size}; $self->{universe} ||= new WebLife::Universe($self->{un +iverse_size}); $self->{pos_server_obj} ||= new WebLife::PositionServer( map_size => $self->{map_size} ); } else { die "No pos_server_addr defined" unless $self->{pos_server_add +r}; } return $self; } ############## POSITION FUNCTIONS ################ =item is_pos_server $sys->is_pos_server Returns true if the WebLife::System object is a position server. =cut sub is_pos_server { return (+shift)->{is_pos_server}; } =item pos_server_addr $sys->pos_server_addr Returns the address of the system's position server. Dies with an erro +r if the system is a position server itself. =cut sub pos_server_addr { my $self = shift; die "I am pos server" if $self->{is_pos_server}; return $self->{pos_server_addr}; } =item run $sys->run Starts the system running. A running system will begin by asking for info from the position server, or by waiting for peers to join the network if it is a position server itself. Once it has the necessary info, it will start calculating its section of the game of life board and exchanging its board map regularly with neighbours. =cut sub run { my $self = shift; while (1) { $self->_mainloop; } } sub send { my $self = shift; my ($msg, $addr) = @_; my $string = $self->{parser}->serialize($msg); $self->{transport}->send($string, $addr); } sub _mainloop { my $self = shift; # receive messages my @msg_strs = $self->{transport}->receive; foreach my $str (@msg_strs) { my $msg = $self->{parser}->parse($str); $self->{messagehandler}->handle($msg); } if ($self->{is_pos_server}) { debug "running position server"; $self->{pos_server_obj}->run; } if ($self->{preparer}->is_ready) { debug "updating neighbours"; $self->_update_nbrs; # this first, otherwise we may skip updat +ing! debug "running game"; $self->{game}->run; } else { debug "getting ready"; $self->{preparer}->get_ready; } } sub _update_nbrs { my $self = shift; my @nbrs = $self->universe->neighbours($self->{position}); my $t = $self->{game}->time; my $msg; my $map = $self->{game}->my_current_map; my $size = $map->size; my $mapstr = $map->as_string; die "No size!" unless $size; foreach my $pos (@nbrs) { next if $self->{updated_nbrs}{$pos}[$t]; my $content = join "\n", "Time: $t", "Pos: $self->{position}", "Map: $mapstr", "Map-size: $size"; $msg ||= new WebLife::Message ( content => $content, params => {type => 'map'} )->from_me; my $addr = $self->addressbook->find_addr($pos); debug "Updating $pos at $addr for time $t "; $self->send($msg, $addr) and $self->{updated_nbrs}{$pos}[$t]++; } } sub delete { my $self = shift; warn "Deleting WebLife::System object"; $SYSTEM = undef; $self = undef; } ##################### SET METHODS ################### =item set_pos $sys->set_pos($pos); $sys->set_pos('1.2'); Sets the system's position. Positions are strings in the format 'row.column'. Row and column start at 0. =cut sub set_pos { my $self = shift; my $pos = shift; if ($self->{position}) { warn "Got position $self->{position} already, not setting"; return; } debug "Setting my position to $pos"; $self->{position} = $pos; $self->addressbook->add($self->address, $pos); } =item set_game $sys->set_game($game); Sets the system's WebLife::Game object. =cut sub set_game { my $self = shift; if ($self->{game}) { warn "Got game already, ignoring"; return; } $self->{game} = shift; } =item set_universe $sys->set_universe($univ); Sets the system's universe object. =cut sub set_universe { my $self = shift; if ($self->{universe}) { warn "Got universe already, ignoring"; return; } $self->{universe} = shift; } ############## ACCESSORS ################ =item game my $game = $sys->game; Retrieves the system's WebLife::Game object. =item universe my $univ = $sys->universe; Retrieves the system's WebLife::Universe object. =item position my $pos = $sys->position; Retrieves the system's current position. =item address my $addr = $sys->address; Retrieves the system's current internet address, including port. =item messagehandler my $mh = $sys->messagehandler; Retrieves the system's WebLife::MessageHandler object. =item pos_server my $ps = $sys->pos_server; Retrieves the system's WebLife::PositionServer object. Returns undef i +f the system is not a position server. =item addressbook my $mh = $sys->addressbook; Retrieves the system's WebLife::AddressBook object. =item parser my $mh = $sys->parser; Retrieves the system's WebLife::Parser object. =back =cut { # privacy for my $subname (qw(game universe addressbook messagehandler address p +osition)){ no strict 'refs'; *{"WebLife::System::$subname"} = sub { my $self = shift; return $self->{$subname}; }; } } # privacy sub pos_server { my $self = shift; return $self->{pos_server_obj}; } { my (%debug, %info, %pos); sub debug { my $msg = shift; my @flags = @_; push @flags, @{[caller(1)]}[0, 3]; # package, subroutine return unless grep {$debug{$_}} @flags; if (scalar keys %pos) { return unless $pos{$SYSTEM->position}; } my @preamble; my $div = '-' x 50; push @preamble, "Address: " .$SYSTEM->address if $info{address}; push @preamble, "Sub: " . @{[caller(1)]}[3] if $info{sub}; push @preamble, "Pos: " . $SYSTEM->position if $info{pos}; $msg = "\n" . join ("\n", $div, @preamble, $msg, $div); # if ($level == 1) { # confess $msg; # } else { print STDERR $msg; # } } sub set_debug { my %opts = @_; $opts{pos} ||= []; $opts{debug} ||= []; $opts{info} ||= []; @pos{ @{$opts{pos}} } = (1) x scalar @{$opts{pos}}; @debug{ @{$opts{debug}} } = (1) x scalar @{$opts{debug}}; @info{ @{$opts{info}} } = (1) x scalar @{$opts{info}}; } } =head2 See also L<WebLife> =cut 1; #== WebLife/PositionServer.pm ################ package WebLife::PositionServer; use WebLife::System qw/$SYSTEM debug/; use strict; sub new { my $class = shift; my $self = bless {@_}, $class; my $it = $SYSTEM->universe->iterator; while (my $pos = $it->()) { my $map = WebLife::Game::Map->random($self->{map_size}); $self->{maps}{$pos} = $map; } return $self; } sub new_position { my $self = shift; # return a position if one is available $self->{iterator} ||= $SYSTEM->universe->iterator; return $self->{iterator}->(); } sub accept_peer { my $self = shift; my $addr = shift; my $pos = $self->new_position(); unless ($pos) { my $msg = new WebLife::Message ( content => 'FULL', params => {type => 'initial_info'} )->from_me; $SYSTEM->send($msg, $addr); } else { $SYSTEM->addressbook->add($addr, $pos); } } sub run { my $self = shift; my $it = $SYSTEM->universe->iterator; my @addrs; while (my $pos = $it->()) { next if defined $SYSTEM->position and $pos eq $SYSTEM->positio +n; my $addr = $SYSTEM->addressbook->find_addr($pos); return unless defined $addr; # not full yet! push @addrs, $addr; } foreach my $addr (@addrs) { $self->{sent_initial_info}{$addr} ||= $self->_send_initial_inf +o($addr); } } sub _send_initial_info { my $self = shift; my ($addr) = @_; my $pos = $SYSTEM->addressbook->find_pos($addr); my @nbrs = $SYSTEM->universe->neighbours($pos); my $content; foreach my $np (@nbrs) { my $addr = $SYSTEM->addressbook->find_addr($np); $content .= "Nbr: $np-$addr\n"; } $content .= join "\n", "Map: " . $self->get_map($pos)->as_string, "Pos: $pos", "Universe-size: " . $SYSTEM->universe->size, "Map-size: " . $self->{map_size} ; my $msg = new WebLife::Message ( content => $content, params => {type => 'initial_info'} )->from_me; $SYSTEM->send($msg, $addr); } sub get_map { my $self = shift; my $pos = shift; return $self->{maps}{$pos}; } 1; #== WebLife/Preparer.pm ################ package WebLife::Preparer; use WebLife::System qw/$SYSTEM debug/; use WebLife::Message; use strict; use vars qw($POLITENESS); $POLITENESS = 60; sub new { my $class = shift; bless {@_}, $class; } sub is_ready { my $self = shift; return 0 unless defined $SYSTEM->position; debug "got position"; return 0 unless defined $SYSTEM->universe; debug "got universe"; return 0 unless defined $SYSTEM->game; debug "got game"; return 0 unless $self->_got_nbrs; debug "got neighbours"; return 1; } sub get_ready { my $self = shift; if (not defined $SYSTEM->position) { $self->_find_pos; } if (not defined $SYSTEM->game) { $self->_find_game; } } sub _find_pos { my $self = shift; $self->{asked_pos} ||= 0; # warnings return if time - $self->{asked_pos} < $POLITENESS; if ($SYSTEM->is_pos_server) { my $pos = $SYSTEM->pos_server->new_position; $SYSTEM->set_pos($pos); } else { my $msg = new WebLife::Message ( params => {type => 'whereami'}, content => '' )->from_me; if ($SYSTEM->send($msg, $SYSTEM->pos_server_addr)) { $self->{asked_pos} = time; } } } sub _find_game { my $self = shift; return unless defined $SYSTEM->position; if ($SYSTEM->is_pos_server) { my $map = $SYSTEM->pos_server->get_map($SYSTEM->position); my $game = new WebLife::Game( map => $map ); $SYSTEM->set_game($game) } } sub _got_nbrs { my $self = shift; defined $SYSTEM->position or die "Can't look for neighbours withou +t position"; defined $SYSTEM->universe or die "Can't look for neighbours withou +t universe"; my @nbrs = $SYSTEM->universe->neighbours($SYSTEM->position); debug "Neighbours: " . join " ", @nbrs; foreach (@nbrs){ unless ($SYSTEM->addressbook->find_addr($_)) { debug "Can't find address for pos $_"; return 0; } } debug "got neighbours"; return 1; } 1; #== WebLife/Game.pm ################ package WebLife::Game; use WebLife::System qw($SYSTEM debug); use WebLife::Game::Map; sub new { # requires map => $map my $class = shift; my $self = {@_}; die "Game requires a map" unless $self->{map}; $self->{time} = 0; bless $self, $class; } sub run { my $self = shift; # debug "running game"; if (defined $SYSTEM->position and $self->{map}) { $self->{maps}->[0]{$SYSTEM->position} = delete $self->{map}; } return unless $self->_ready_to_update; my $bigmap = $self->_build_temp_map; debug "Neighbour map at $self->{time}:\n" . $bigmap->dump; my $newmap = $self->_run_map($bigmap); $self->{time}++; # debug "Updating map:\n" . $newmap->dump; $self->_save_my_new_map($newmap); } sub time { my $self = shift; return $self->{time}; } sub add_map { my $self = shift; my ($pos, $time, $map, $mapsize) = @_; $map = WebLife::Game::Map->from_string($map, $mapsize) unless ref +$map; $self->_save($map, $pos, $time); } sub my_current_map { my $self = shift; return $self->{maps}[$self->{time}]{$SYSTEM->position} || $self->{ +map}; } sub _build_temp_map { my $self = shift; my @nine = $SYSTEM->universe->unnormalized_nine_square($SYSTEM->po +sition); my @mydims = split /\./, $SYSTEM->position; my $bigmap; my $small_map_size; foreach my $pos (@nine) { my $npos = $SYSTEM->universe->normalize($pos); my $m = $self->{maps}[$self->{time}]{$npos}; $small_map_size ||= $m->size; #shd always be the same $bigmap ||= new WebLife::Game::Map($small_map_size * 3); # debug "adding in map for $npos\n" . $m->dump; my @dims = split /\./, $pos; @dims = map {$dims[$_] - $mydims[$_]+1}(0 .. 1); #relativize # top left shd be 0,0 foreach my $sq ($m->squares) { my $val = $m->value($sq); $sq->[0] += $dims[0] * $small_map_size; $sq->[1] += $dims[1] * $small_map_size; $bigmap->set_value($sq, $val); } } debug "Built temporary map:\n" . $bigmap->dump; return $bigmap; } sub _run_map { my $self = shift; my $map = shift; debug "Neighbour map at time $self->{time}:\n" . $map->dump; my $turns = $map->size / 3; for (1 .. $turns) { $map = $self->_run_map_once($map); } debug "New map for time $self->{time} + 1:\n" . $map->dump; return $map; } sub _run_map_once { my $self = shift; my $map = shift; my $newmap = new WebLife::Game::Map($map->size - 2); foreach my $sq ($map->squares) { my @nbrsq = $map->nbrs($sq); next if @nbrsq < 8; # edge my $total; my $newsq; $newsq->[0] = $sq->[0] - 1; $newsq->[1] = $sq->[1] - 1; map { my $value = $map->value($_) || 0; $total+= $value; }@nbrsq; if ($total < 2 or $total > 3) { $newmap->set_value($newsq, 0); } elsif ($total == 3) { $newmap->set_value($newsq, 1); } else { $newmap->set_value($newsq, $map->value($sq)); } } debug "new map\n" . $newmap->dump; return $newmap; } sub _save_my_new_map { my $self = shift; $self->{maps}[$self->{time}]{$SYSTEM->position} = shift; } sub _save { my $self = shift; my ($map, $pos, $time) = @_; debug "Saving map\n" . $map->dump . "\nfor pos $pos at time $time" +; $self->{maps}[$time]{$pos} = $map; } sub _ready_to_update { my $self = shift; return 0 unless $SYSTEM->position; my @nbrs = $SYSTEM->universe->neighbours($SYSTEM->position); my $n = 0; my $s = 1; my @miss; # debug "nbrs are: " . join "\t", @nbrs; foreach my $pos (@nbrs) { unless (defined $self->{maps}->[$self->{time}]->{$pos}){ $s = 0; push @miss, $pos; } else { $n++; } } debug "Got $n nbr maps for time $self->{time}: success $s: missing +" . join " ", @miss; return $s; } 1; #== WebLife/Transport.pm ################ package WebLife::Transport; use IO::Socket; use IO::Select; use WebLife::System qw(debug $SYSTEM); use strict; use vars qw($WRITE_TIMEOUT $READ_TIMEOUT); $WRITE_TIMEOUT = 90; $READ_TIMEOUT = 1; =pod parent--->sends messages. Timeout | | forwards messages "as and when", with a very quick timeout so that child never waits for parent ^ | | child<---gets messages. No need to wait for sending! =cut sub new { my $class = shift; my $self = {port => shift}; bless $self, $class; my $pid = open RECEIVER, "-|"; defined $pid or die "Can't fork receiver: $!"; if (! $pid) { # in child $self->_receiver_run; # never returns } else { # in parent $self->{read_fh} = \*RECEIVER; $self->{receiver_pid} = $pid; return $self; } } sub send { my $self = shift; my $string = shift; my $addr = shift; debug "No address!" unless $addr; my $socket = new IO::Socket::INET ( PeerAddr => $addr, Timeout => $WRITE_TIMEOUT, ) or die "Couldn't create socket to $addr: $@"; my $sent = $socket->send($string); $socket->shutdown(2); debug "Sent $sent chars of message:\n$string\nto $addr"; return $sent; } sub receive { my $self = shift; my $line; local $@; local $SIG{ALRM} = sub {die "WebLife timeout";}; eval { alarm 1; $line = readline($self->{read_fh}); }; alarm 0; if ($@ =~ /WebLife timeout/) { return (); } elsif ($@) { die $@; } debug "first line of msg: $line"; die "Bad read from child: $line" unless $line =~ /MSG\s(\d+)/; my $ln = $1; my $msg; read $self->{read_fh}, $msg, $ln; debug "Read message:\n$msg\nfrom child"; return ($msg); } sub DESTROY { my $self = shift; kill 'QUIT' => $self->{receiver_pid} if $self->{receiver_pid}; my $fh = $self->{read_fh}; close $fh if $fh; } ############## CHILD METHODS ################### sub _receiver_run { # child only # child writes to STDOUT my $self = shift; $|=1; $self->{queue} = []; $self->{socket} = new IO::Socket::INET( Listen => 1, LocalPort => $self->{port}, ) or die $!; $self->{select} = new IO::Select ($self->{socket}); while (1) { $self->_get_msgs; $self->_pass_msgs; } } sub _get_msgs { my $self = shift; my @msgs; my $sel = $self->{select}; my $lsn = $self->{socket}; local $SIG{PIPE} = 'IGNORE'; while (my @readable = $sel->can_read($READ_TIMEOUT)) { last unless @readable; foreach my $sock (@readable) { if ($sock == $lsn) { my $rdr = $lsn->accept; $sel->add($rdr); } else { my $str; while (my $l = $sock->getline) { $str .= $l; } $sel->remove($sock); $sock->close; debug "Child received message:\n$str"; push @msgs, $str; } } } push @{$self->{queue}}, @msgs; } sub _pass_msgs { my $self = shift; my $msg = shift @{$self->{queue}}; return unless $msg; local $@; local $SIG{ALRM} = sub {die "WebLife timeout";}; eval { alarm 1; syswrite STDOUT, "MSG " . length ($msg) . "\n$msg"; }; alarm 0; if ($@ and $@ =~ /WebLife timeout/) { unshift @{$self->{queue}}, $msg; # try again } elsif ($@) { die $@; } else { debug "Printed message:\n$msg\nto parent"; } return; } 1; #== WebLife/AddressBook.pm ################ package WebLife::AddressBook; sub new { my $class = shift; bless {@_}, $class; } sub remove { my $self = shift; my $addr = shift; delete $self->{$addr}; } sub add { my $self = shift; my ($addr, $pos) = @_; $self->{$addr} = $pos; } sub find_addr { my $self = shift; my $pos = shift; my ($addr) = grep {$self->{$_} eq $pos} keys %$self; return $addr; } sub find_pos { my $self = shift; my $addr = shift; return $self->{$addr}; } 1; #== WebLife/Message.pm ################ package WebLife::Message; use strict; use WebLife::System qw($SYSTEM); sub new { my $class = shift; bless {@_}, $class; } sub params { my $self = shift; return keys %{$self->{params}}; } sub from_me { my $self = shift; $self->{params}{from} = $SYSTEM->address; return $self; } sub param { my $self = shift; return $self->{params}{+shift}; } sub content { my $self = shift; return $self->{content}; } 1; #== WebLife/MessageHandler.pm ################ package WebLife::MessageHandler; =head1 WebLife::MessageHandler Class to handle messages for the WebLife module. =cut use strict; use WebLife::System qw($SYSTEM debug); use WebLife::Game; use WebLife::Game::Map; use WebLife::Universe; use Carp qw(confess); use vars qw(%TABLE); %TABLE = ( whereami => '_handle_pos_request', # pos => '_handle_peer_pos', # obsolete? use lat +er for peer migration map => '_handle_peer_map', initial_info=> '_handle_initial_info', ); =head2 Methods =over 4 =item new new WebLife::MessageHandler->new(%options); Creates a new MessageHandler object. No options are currently used. =cut sub new { my $class = shift; bless {@_}, $class; } =item handle $mh->handle($msg); Handles a WebLife::Message object and performs the appropriate action. =back =cut sub handle { my $self = shift; my $msg = shift; my $method = $TABLE{$msg->param('type')}; $self->$method($msg); } sub _handle_pos_request { my $self = shift; my $msg = shift; my $peeraddr = $msg->param('from'); if ($SYSTEM->is_pos_server) { $SYSTEM->pos_server->accept_peer($peeraddr); } else { $self->_forward($msg, $SYSTEM->pos_server_addr) } } sub _handle_initial_info { my $self = shift; my $msg = shift; my $from = $msg->param('from'); unless ($from eq $SYSTEM->pos_server_addr) { warn "Got initial info, but not from position server address: +ignoring"; return; } if ($msg->content eq 'FULL') { die "Position server has no spare positions"; } my ($mapstr, $mapsize); my @lines = split /\n/, $msg->content; foreach (@lines) { /^([^:]+):\s*(.*)/; if ($1 eq 'Nbr') { my ($pos, $addr) = split /-/, $2; debug "Adding nbr pos $pos at $addr"; $SYSTEM->addressbook->add($addr, $pos); } elsif ($1 eq 'Map') { $mapstr = $2; } elsif ($1 eq 'Pos') { debug "Setting pos to $2"; $SYSTEM->set_pos($2); } elsif ($1 eq 'Universe-size') { my $univ = WebLife::Universe->new($2); $SYSTEM->set_universe($univ); } elsif ($1 eq 'Map-size') { $mapsize = $2; } } my $map = WebLife::Game::Map->from_string($mapstr, $mapsize); $SYSTEM->set_game( WebLife::Game->new(map => $map) ); if ($self->{map_msg_queue}) { foreach my $msg (@{ $self->{map_msg_queue} }) { $self->_handle_peer_map($msg); } } } # sub _handle_peer_pos { # my $self = shift; # my $msg = shift; # # my @lines = split /\n/, $msg->content; # foreach (@lines) { # /(.*?)\s*-\s*(.*)/; # $SYSTEM->addressbook->add($1,$2); # } # } sub _handle_peer_map { my $self = shift; my $msg = shift; my @lines = split /\n/, $msg->content; my ($pos, $time, $mapstr, $size); foreach my $ln (@lines) { $ln =~ /([^:]*):\s*(.*)/; $1 eq 'Pos' and $pos = $2; $1 eq 'Time' and $time = $2; $1 eq 'Map' and $mapstr = $2; $1 eq 'Map-size' and $size = $2; } debug "Parsed message as:\npos $pos\ntime $time\nmap string $mapst +r\nsize $size"; # HACK! if (defined $SYSTEM->game) { $SYSTEM->game->add_map($pos, $time, $mapstr, $size); } else { push @{$self->{map_msg_queue}}, $msg; } } sub _forward { my $self = shift; my ($msg, $addr) = @_; $SYSTEM->send($msg, $addr); } =head2 See also L<WebLife>, L<WebLife::Messsage> =cut 1; #== WebLife/Parser.pm ################ package WebLife::Parser; use WebLife::Message; use WebLife::System qw(debug); sub new { my $class = shift; bless {@_}, $class; } sub parse { my $self = shift; my $string = shift; my %env; while ($string =~ s/(.*?)\n//s) { length $1 or last; # two newlines end envelope $_ = $1; /(.*?):\s*(.*)\s*/ or die "Faulty message"; $env{params}{$1} = $2; } $env{content} = $string; return WebLife::Message->new(%env); } sub serialize { my $self = shift; my $message = shift; my $string; foreach my $param ($message->params) { $string .= "$param: " . $message->param($param) . "\n"; } $string .= "\n"; $string .= $message->content; return $string; } 1; #== WebLife/Test.pm ################ # WARNING: this is probably out of date apart from test_all(); # usage: perl -MWebLife::Test -e 'test_all()'; package WebLife::Test; use strict; use Exporter; use Data::Dumper qw(Dumper); use Carp; use base 'Exporter'; use vars qw/@EXPORT $TTY/; @EXPORT = qw( test_universe test_game test_transport test_parser test_pos_server test_addressbook test_messagehandler test_all test ); use WebLife::System qw($SYSTEM set_debug); # BEGIN {*CORE::GLOBAL::die = \&Carp::confess;} set_debug( debug => [ # 'WebLife::Game::_ready_to_update', # 'WebLife::System::_update_nbrs', # 'WebLife::System::_mainloop', # 'WebLife::Game::_build_temp_map', # 'WebLife::Game::_run_map_once', # 'WebLife::Game::_run_map', 'WebLife::Game::run', # 'WebLife::Game::Map::as_string', # 'WebLife::Game::Map::from_string', # 'WebLife::MessageHandler::handle_initial_info', # 'WebLife::MessageHandler::handle_peer_map', # 'WebLife::System::set_pos', # 'WebLife::Preparer::is_ready', # 'WebLife::Preparer::_got_nbrs', # 'WebLife::Transport::receive', # 'WebLife::Transport::send', # 'WebLife::Transport::_pass_msgs', # 'WebLife::Transport::_get_msgs', # 'WebLife::Transport::new', ], info => [ 'sub', 'address', 'pos', ], pos => [ '1.1', # '1.0' ], ); sub test { foreach (@_){ eval "test_$_()"; die $@ if $@; } } sub test_game { require WebLife::Game; my $size = 5; my $map = new WebLife::Game::Map ($size * 3); foreach ($map->squares) { $map->set_value($_, int rand 2); } print "Testing update of map\n"; print "Initial map\n"; print $map->dump; my $g = new WebLife::Game( size => $size, map => $map, ); my $newmap = $g->_run_map($map); print "Map after $size turns\n"; print $newmap->dump; print "Testing single turn of game\n"; my $s = new WebLife::System; } sub test_universe { require WebLife::Universe; my $u = new WebLife::Universe (10); my @p = qw(11.11 0.0 0.11 5.5 5.11 -1.-1 -1.-11); for (@p) { print "prenormalize: $_\t"; print "normalized:" . $u->normalize($_) . "\n"; } for (qw(5.5 10.10)) { print "position $_\n"; map {print "\tneighbour $_\n"} $u->neighbours($_); } my $it = $u->iterator; print "iterator\n"; while (my $pos = $it->()) { print "$pos\n"; } } sub test_transport { require WebLife::Transport; my $port = 54331; unless (my $chld = fork()) { print "Listening\n"; my $lsnr = new WebLife::Transport($port); my %check; while (1) { my @msgs = $lsnr->receive; foreach (@msgs) { /msg (\d+) of (\d+)/ and $check{$2}{$1}++; print "Got all messages from stress test of $2\n" if s +calar keys %{$check{$2}} == $2; } } } else { sleep 2; my $sndport = $port; for my $stress(1 .. 4) { $stress *= 5; print "\n\nStress testing with $stress connections\n"; for (1 .. $stress) { my $sndr = new WebLife::Transport(++$sndport); $sndr->send("msg $_ of $stress", "localhost:$port"); } sleep $stress; } kill 'QUIT' => $chld; } } sub test_parser { require WebLife::Parser; require WebLife::Message; my $p = new WebLife::Parser; my $type = 'greeting'; my $from = 'me'; my $cont = "hello\n\n\twelcome from: Zanzibar\n"; print "Serializing message of type $type from $from, content $cont +\n"; my $m = new WebLife::Message ( content => $cont, params => {type => $type, from => $from}, ); print "==RESULT==\n"; my $str = $p->serialize($m); print "$str\n====\n"; my $back = $p->parse($str); print "Parsing result\n"; print Dumper $back; } sub test_pos_server { require WebLife::System; require WebLife::PositionServer; my $s = new WebLife::System ( is_pos_server => 1, map_size => 3, universe_size => 3, ); while (my $pos = $s->pos_server->new_position) { print "Position server served pos $pos\n"; } } sub test_addressbook { require WebLife::AddressBook; my $a = new WebLife::AddressBook; my @addr = qw( 127.0.0.1:4321 123.23.231.1:4321 33.44.11.22:4321 211.21.0.7:4321 ); my @pos = qw(1.1 1.2 2.1 2.2); for (0 .. $#pos) { $a->add($addr[$_], $pos[$_]); } my $seen; for (0 ..1) { foreach (@pos) { print "Addr for pos $_: " . $a->find_addr($_); print "\n"; } foreach (@addr) { print "Pos for addr $_: " . $a->find_pos($_); print "\n"; } print "Now removing addrs\n" unless $seen++; foreach (@addr){ $a->remove($_); } } } sub test_messagehandler { require WebLife::System; require WebLife::Message; require WebLife::MessageHandler; my $other = '127.2.3.1:4321'; my $s = new WebLife::System( map_size => 3, is_pos_server => 1, universe_size => 3, ); print "Handling whereami message with pos_server\n"; my $m = new WebLife::Message( content => '', params => { type => 'whereami', from => $other, } ); $s->messagehandler->handle($m); $s->delete; # redefine $SYSTEM $s = new WebLife::System(pos_server_addr => $other); print "Handling 'FULL' initial_info message\n"; my $m = new WebLife::Message( content => 'FULL', params => { type => 'initial_info', from => $other, } ); eval { $s->messagehandler->handle($m); }; print $@? "Died: $@\n" : "Didn't die!\n"; print "Handling initial_info message\n"; my $info = join ("\n", "Nbr: 1.1-foo.bar.com:4321", "Nbr: 1.2-bar.bat.com:4321", "Nbr: 2.2-blah.net:4321", "Map: 010010010" ); print "Message:\n=====\n$info\n=====\n"; $m = new WebLife::Message ( content => $info, params => {type => 'initial_info', from => $other} ); $s->messagehandler->handle($m); print "My map is now:\n" . $s->game->my_current_map->dump . "\n"; print "My address book:\n" . Dumper ($s->addressbook) . "\n"; print "Handling map message\n"; my $mapstr = $s->game->my_current_map->as_string; $mapstr = $s->addressbook->find_pos($other) . "\n0\n$mapstr"; $m = new WebLife::Message( content => $mapstr, params => { type => 'map', from => $other } ); $s->messagehandler->handle($m); print "Map for node at $other is:\n"; print $s->game->{maps}->[0]{$s->addressbook->find_pos($other)}->du +mp; print "(Cheating by looking inside game hashref)\n"; print "Should be same as my own map:\n"; print $s->game->my_current_map->dump; } sub test_all { require WebLife::System; my $map_size = 10; my $univ_size = 7; my $svrs = $univ_size ** 2; my $port = 4331; my @kids; for my $i (1 .. $svrs-1) { $TTY = $i+1; if (my $kid = fork) { $DB::inhibit_exit = 0; push @kids, $kid; } else { # in child sleep 5; # time for the parent to start my $myport = $port + $i; my $s = new WebLife::System( pos_server_addr => "localhost:$port", address => "localhost:$myport", ); $s->run; } } my $svr = new WebLife::System( map_size => $map_size, is_pos_server => 1, universe_size => $univ_size, ); *WebLife::System::DESTROY = sub { warn "Killing children"; map {kill 'QUIT' => $_} @kids; }; $svr->run; } package DB; sub get_fork_TTY { my $tty = "/dev/pts/$WebLife::Test::TTY"; warn "Forking tty to $tty"; $DB::fork_TTY = $tty; return $tty; } 1; #== WebLife/Transport.pm.nonforking ################ # The old version. Works fine, so you can use this if you want, # but probably breaks earlier under stress package WebLife::Transport; use IO::Socket; use IO::Select; use WebLife::System qw(debug $SYSTEM); use strict; use vars qw($WRITE_TIMEOUT $READ_TIMEOUT); $WRITE_TIMEOUT = 15; $READ_TIMEOUT = 1; sub new { my $class = shift; bless {port => shift}, $class; } sub send { my $self = shift; my $string = shift; my $addr = shift; debug "No address!" unless $addr; my $socket = new IO::Socket::INET ( PeerAddr => $addr, ) or die "Couldn't create socket to $addr: $@"; $socket->timeout($WRITE_TIMEOUT); $socket->send($string); $socket->shutdown(2); debug "Sent message:\n$string\nto $addr", 'send'; return 1; } sub receive { my $self = shift; my $port = $self->{port}; local $SIG{PIPE} = 'IGNORE'; my @msgs; $self->{socket} ||= new IO::Socket::INET( Listen => 1, LocalPort => $port, ); my $lsn = $self->{socket}; $self->{select} ||= new IO::Select ($lsn); my $sel = $self->{select}; while (my @readable = $sel->can_read($READ_TIMEOUT)) { last unless @readable; foreach my $sock (@readable) { if ($sock == $lsn) { my $rdr = $lsn->accept; $sel->add($rdr); } else { my $str; while (my $l = $sock->getline) { $str .= $l; } $sel->remove($sock); $sock->close; debug "received message:\n$str", 'receive'; push @msgs, $str; } } } return @msgs; } 1; #== WebLife/Universe.pm ################ package WebLife::Universe; use strict; use WebLife::System qw(debug); sub new { my $class = shift; my $self = {max_dims => shift}; bless $self, $class; } sub size { my $self = shift; return $self->{max_dims}; } sub neighbours { my $self = shift; my $pos = shift; $pos = $self->normalize($pos); my @pos = $self->unnormalized_nine_square($pos); my @norm; foreach (@pos) { push @norm, $self->normalize($_); } my %seen; # necessary for universe with size 2! return grep {$_ ne $pos and not $seen{$_}++} @norm; } sub unnormalized_nine_square { my $self = shift; my $pos = shift; $pos = $self->normalize($pos); # find all positions next to $pos my ($x, $y) = split /\./, $pos; my @pos = map { my $cx = $_; map {"$cx.$_"} ($y-1 .. $y+1) } ($x-1 .. $x+1); return @pos; } sub normalize { my $self = shift; my $pos = shift; my ($x, $y) = split /\./, $pos; my $max = $self->{max_dims}; while ($x < 0) {$x+= $max;} while ($y < 0) {$y+= $max;} while ($x >= $max) {$x -= $max;} while ($y >= $max) {$y -= $max;} return "$x.$y"; } sub _max_dims { my $self = shift; return ($self->{max_dims}) x 2; } sub iterator { my $self = shift; my $pos = '0.-1'; my ($max_x, $max_y)= $self->_max_dims; my $it = sub { my @dims = split /\./, $pos; if (++$dims[1] >= $max_y) { $dims[0]++; $dims[1] = 0; } if ($dims[0] >= $max_x) { return undef; } $pos = "$dims[0].$dims[1]"; return $pos; }; return $it; } 1; #== WebLife/Game/Map.pm ################ package WebLife::Game::Map; use WebLife::System qw(debug $SYSTEM); use Data::Dumper qw(Dumper); use Carp qw(confess); use strict; use vars qw($SPARSITY); $SPARSITY = 5; sub new { my $class = shift; confess "No size at " . $SYSTEM->position unless $_[0]; bless {size => shift}, $class; } sub random { my $class = shift; my $self = $class->new(@_); foreach ($self->squares) { my $val = (int rand $SPARSITY)? 0:1; $self->set_value($_, $val); } return $self; } sub from_string { my $class = shift; my ($str, $size) = @_; debug "Parsing map string $str"; my $self = $class->new($size); foreach my $pos (split /,/, $str) { my ($x, $y) = split /:/, $pos; $self->set_value([$x, $y], 1); } local $Data::Dumper::Deepcopy = 1; debug "Created map object:\n" . Dumper ($self); return $self; } sub as_string { my $self = shift; local $Data::Dumper::Deepcopy = 1; debug "Serializing map object:\n" . Dumper ($self); my @ones; foreach my $sq (grep {$self->value($_)} $self->squares) { push @ones, "$sq->[0]:$sq->[1]"; } debug "Created map string " . join ",", @ones; return join ",", @ones; } sub dump { my $self = shift; my @dim = (1 .. $self->{size}); my $dump = "\n"; for my $x (@dim) { for my $y (@dim) { $dump .= $self->value([$x, $y])? 'x' : '.'; } $dump .= "\n"; } $dump .= "\n"; return $dump; } sub size { my $self = shift; return $self->{size}; } sub set_value { my $self = shift; my $sq = shift; my $val = shift; $self->{squares}->[$sq->[0]]->[$sq->[1]] = $val; } sub nbrs { my $self = shift; my $sq = shift; my ($x, $y) = @$sq; my @nbrs = map { my $cx = $_; map {[$cx, $_]} ($y-1 .. $y+1) } ($x-1 .. $x+1); @nbrs = grep { $_->[0] >= 1 and $_->[0] <= $self->{size} and $_->[1] >= 1 and $_->[1] <= $self->{size} and ($_->[0] != $x or $_->[1] != $y) } @nbrs; } sub squares { my $self = shift; my $size = $self->{size}; my @sq = map { my $x = $_; map {[$x, $_]} (1 .. $size) } (1 .. $size); return @sq; } sub value { my $self = shift; my $sq = shift; return $self->{squares}->[$sq->[0]]->[$sq->[1]]; } 1;
In reply to WebLife: peer-to-peer Game of Life by dash2
| For: | Use: | ||
| & | & | ||
| < | < | ||
| > | > | ||
| [ | [ | ||
| ] | ] |