return the address of an anonymous glob

I'd be vaguely uncomfortable with the idea that memory could be recycled and at some point you would generate the symbol name more than once.

I would be inclined to extend the symbol name to include the current thread id:

use Config ();

sub gensym () {
    my $id = $Config{useithreads} ? threads->tid . '-' : '';
    my $name = "GEN$t" . $genseq++;
    my $ref = \*{$genpkg . $name};
    delete $$genpkg{$name};
    $ref;
}
[download]

But, as the names are immediately deleted from the symbol table each time:

delete $$genpkg{$name};
[download]

before the reference is returned to the caller, they can never again be referenced by name, so I don't think there is the possibility for confusion there. Hence, as the sequenced names are never used beyond the point of creation, there seems no reason for sequencing them in the first place when local can give us a new, unnamed glob whenever we want one?

I'm guessing the current implementationis simply a part of history from before local was available--and definitely predating me.

---

Examine what is said, not who speaks -- Silence betokens consent -- Love the truth but pardon error.

"Science is about questioning the status quo. Questioning authority".

In the absence of evidence, opinion is indistinguishable from prejudice.

"Too many [] have been sedated by an oppressive environment of political correctness and risk aversion."

simply a part of history from before local was available

No. local predates modules and so also predates the Symbol module.

The generated name can be output when the file handle is dumped and it is nice to be able to distinguish between two file handles in such debug output. Hence unique names are generated.

You also appear to have disproven your own argument that the numbers overlapping between threads might cause a problem, especially since your proposed solution to that problem is to eliminate the numbers. :)

- tye        

our %appdata;
*appdata = \%SOD::Config::appdata;
[download]

my $planet = SOD::Planet->new($dbh, $some_id);
my $stats = $planet->game_stats->record;
[download]

$self->{GAMESTATS} ||= SOD::SharedObject::PlanetStatus->new($self->{ID
+});
[download]

sub new {
   my ($class, $type, $id) = @_;
   die "You must construct a SharedObject with a type" unless $type;
   my $self = { TYPE     => $type,
                ID       => $id,
                MODIFIED => 0,
                RECORD   => {}
              };
   bless $self, $class;
   # retrieve data from the shared objects cache:
   if ($id) {
      my ($sock, $req, $res);
      $sock = IO::Socket::INET->new ( PeerAddr => $appdata{SOBJIP}, # 
+127.0.0.1
                                      PeerPort => $appdata{SOBJPORT}, 
+# 8000
                                      Proto    => 'tcp',
                                      Type     => SOCK_STREAM,
                                      Reuse    => 1) || die $!;
      $req = SOD::Session::Client::Request->new($appdata{SOBJCOMMAND},
+ $appdata{SOBJCONTENT}); # SOBJCOMMAND == 6, SOBJCONTENT == 8
      $res = SOD::Session::Client::Response->new($appdata{SOBJCOMMAND}
+, $appdata{SOBJCONTENT});
      unless ($req->send($sock, 'get   ', { 'type' => $type, 
                                            'id'   => $id 
                                          })) {
         die SOD::Session::Error::get($req->error->get)."\t".$req->err
+or->msg;
         $sock->close || die $!;
      }
      unless ($res->receive($sock)) {
         die SOD::Session::Error::get($res->error->get)."\t".$res->err
+or->msg;
      }
      $sock->close || die $!;
      undef $sock;
      $self->{RECORD} = $res->content;
   }
   $self;
}
[download]

   unless ($req->send($sock, 'save  ', { 'type'   => $self->{TYPE}, 
                                         'id'     => $self->{ID},
                                         'object' => $self->{RECORD}
                                       })) {
   [...]
[download]

sub send {
   my $self = shift || return 0;
   return 0 unless ref $self;
   unless (@_ == 3) {
      $self->{ERROR}->set(ILL_NUM);
      return 0;
   }
   my $sock;
   ($sock, $self->{COMMAND}, $self->{CONTENT}) = @_;
   $self->{ERROR}->set(ILL_ARG1) if ref $self->{COMMAND};
   $self->{ERROR}->set(ILL_ARG2) unless ref $self->{CONTENT};
   return 0 if $self->{ERROR}->get;

   $self->{CONTENT} = freeze $self->{CONTENT};

   # COMMANDSIZE is what SOBJCOMMAND was for the caller,
   # CONTENTSIZE refers to SOBJCONTENT in this example (just
   # a primitive protocol)
   my $str = sprintf("%".$self->{COMMANDSIZE}."s", $self->{COMMAND}) .
                sprintf("%0".$self->{CONTENTSIZE}."d", CORE::length($s
+elf->{CONTENT})) .
             $self->{CONTENT};
   local $\ = undef; # the magic
   unless ($sock->send($str)) {
      $self->{ERROR}->set(SOCK_SEND, $!);
      return 0;
   }
   1;
}
[download]

sub receive {
   my $self = shift;                                  # Perl OO mantra
+ ...
   return undef unless ref $self;                     # .. continued
   unless (@_) {
      $self->{ERROR}->set(ILL_NUM);
      return 0;
   }
   my $sock = shift;
   local $/ = undef; # again the magic
   unless (defined ($sock->recv ($self->{COMMAND}, $self->{COMMANDSIZE
+})) && 
       defined ($sock->recv ($self->{CONTENT_LENGTH}, $self->{CONTENTS
+IZE})) && 
       defined ($sock->recv ($self->{CONTENT}, $self->{CONTENT_LENGTH}
+))) {
      $self->{ERROR}->set(SOCK_RECV);
      return 0;
   }
   1;
}
[download]

eval "_".$req->command;
[download]

sub _save {
   my $cont = $req->content; 
   $logs->enqueue("Cacheing $cont->{'type'} $cont->{'id'}") if $DEBUG;
   my $time = $::server_time;
   if ($cont->{'type'} eq 'planet') {
      lock %planets;
      if (exists $planets{$cont->{'id'}}) {
         unless ($planets{$cont->{'id'}}->{'deleted'}) {
            my $old = thaw $planets{$cont->{'id'}}->{'object'};
            $old = __merge($old, $cont->{'object'});
            $planets{$cont->{'id'}}->{'object'} = freeze $old;
            $planets{$cont->{'id'}}->{'atime'} = $time;
            $planets{$cont->{'id'}}->{'modified'} = 1;
         }
      }
      else {
         # this is the point our last discussion was about:
         my %el : shared = ( 'object'    => freeze($cont->{'object'}),
                             'atime'     => $time,
                             'modified'  => 1,
                             'deleted'   => 0
                            );
         $planets{$cont->{'id'}} = \%el;
      }
   }
   [...]
}
[download]

The first thing I notice is that you are assuming that when you do $sock->recv( $buf, 10 ), that provided the call doesn't return undef, then you will have received the number of bytes requested. I think that this is mistaken and that recv will fetch as many bytes as are available up to the number requested, but it may be less. For your short command packets this probably won't occur, but when you are sending large blocks of serialised content, even though you are sending it as a single chunk, the tcp protocol is free to break it up into a number of packets for transmission. That means that your code may be receiving partial transmissions.

You aren't going to want to hear this, but all in all, your 'protocol' handling seems to be very sloppy, leaving numerous windows of opportunity for failure. At the very least you need to have your recv code check the number of bytes received and loop back for more if it didn't get enough. You should probably also be checking the number of bytes sent, though that's generally less of a concern.

Possibly the best solution would be to ditch your (from your own comments:) "primitive protocol", and switch to using a known good implementation of a well tested protocol. From what I can see, HTTP GET and the lesser known PUT would meet most of your requirements.

Whilst it may seem like a lot of work, I think switching your code to use HTTP::Daemon with it's long pedigree would probably be easier than trying to fix up your home-brew protocol implementation to cover all the possibilities and caveats that HTTP has already got covered and Gisle Aas has already implemented.

You might also consider something like HTTP::Daemon::Threaded, though that is much less well proven and so something of an unknown quantity.

Also, from my first glance at your _merge() routine, it looks to me that it is, at the very best, doing things the hard way in terms of walking the parallel structures to discover differences. I think it could be made considerably simpler. And faster. I also think I see possibilities for corruption, but I need to sit down and go through it again when I've got nothing else on the go. I'll get back to you on that.

Sorry that this is rather negative, but you really do need to fix your protocol handling, and sooner rather than later.

---

Examine what is said, not who speaks -- Silence betokens consent -- Love the truth but pardon error.

"Science is about questioning the status quo. Questioning authority".

In the absence of evidence, opinion is indistinguishable from prejudice.

"Too many [] have been sedated by an oppressive environment of political correctness and risk aversion."

you are definitely right. this Session::... stuff is rather ancient code and has never been changed since, and the reason why it has always worked before might simply be that session objects don't become large. but planets and fleets data do, and i'm quite sure that's where the difficulties came from. i modified the respective parts as follows:

sub receive {
   my $self = shift;                                  # Perl OO mantra
+ ...
   return undef unless ref $self;                     # .. continued
   unless (@_) {
      $self->{ERROR}->set(ILL_NUM);
      return 0;
   }
   my $sock = shift;
   local $/ = undef;
   unless (defined $sock->recv($self->{COMMAND}, $self->{COMMANDSIZE})
+ && 
           defined $sock->recv($self->{CONTENT_LENGTH}, $self->{CONTEN
+TSIZE})) {
      $self->{ERROR}->set(SOCK_RECV);
      return 0;
   }
   my $cont = '';
   $self->{CONTENT} = '';
   while (length $self->{CONTENT} < $self->{CONTENT_LENGTH}) {       
      unless (defined $sock->recv($cont, $self->{CONTENT_LENGTH})) {
         $self->{ERROR}->set(SOCK_RECV);
         return 0;
      }
      $self->{CONTENT} .= $cont;
      $cont = '';
   }
   1;
}
[download]

and, although the loop doesn't seem to be necessary:

sub send {
   my $self = shift;
   return undef unless ref $self;
   my $sock = shift || $self{ERROR}->set(ILL_NUM);
   return 0 if $self->error->get;
   $self->{CONTENT_LENGTH} = length $self->{CONTENT};
   my $str = sprintf("%$self->{CODESIZE}s", $self->{CODE}) 
           . sprintf("%$self->{CONTENTSIZE}d", $self->{CONTENT_LENGTH}
+)
           . $self->{CONTENT};
   my $length = length $str;
   local $\ = undef;
   my ($sent, $tsend) = (0, 0);
   while ($sent < $length) {
      unless ($tsent = $sock->send($str)) {
         $self->error->set(SOCK_SEND, $!);
         return 0;
      }
      $sent += $tsent;
      $tsent = 0;
   }
   1;
}
[download]

i'm quite sure that this will fix the problem, and once again you nearly saved my life. :)
--------------------------------
masses are the opiate for religion.