mixing threads and Time::HiRes::ualarm() in perl5.10.0 on FreeBSD 7 segfaults

[p5pRT]

Migrated from rt.perl.org#61288 (status was 'rejected')

Searchable as RT61288$

[p5pRT]

From Simon.Gray@Sophos.com

To​: perlbug@​perl.org
Subject​: threads and Time​::HiRes ualarm() segfaults on FreeBSD 7
Reply-To​: user@​freebsd7_simon.eng.sophos
Message-Id​: <5.10.0_5192_1229002305@​freebsd7_simon.eng.sophos>

This is a bug report for perl from user@​freebsd7_simon.eng.sophos,
generated with the help of perlbug 1.36 running under perl 5.10.0.

#!/usr/bin/perl

=head1 NAME

udp_server.pl - Simple sample udp echo server

=head1 SERVER SYNOPSIS

  perl udp_server.pl --log_level 3
  # default is to not background

=head1 CLIENT SYNOPSIS

  # In another terminal

  perl udp_server.pl --client

=cut

package MyUDPD;
use strict;
use warnings;
use Data​::Dumper;

  #use IO​::Socket qw(MSG_DONTWAIT);
  #use IO​::Select;
  use Time​::HiRes qw(alarm sleep usleep ualarm setitimer ITIMER_VIRTUAL ITIMER_REAL ITIMER_PROF);

use Socket;
use Sys​::Hostname;
use POSIX;

my $port = 5151;
#my $host = 'localhost';
my $host = "10.101.100.231";
my $recv_length = 1024; # packet size

### what type of server is this - we could
### use multi type when we add command line
### parsing to this http server to allow
### for different configurations
use base qw(Net​::Server​::PreFork);

if (grep {/\bclient\b/i} @​ARGV) {
  handle_client();

} else {
  ### run the server
  MyUDPD->run( port => "$host​:$port/udp",
  lock_file => "fred",
  # we could also do the following​:
  # port => '*​:20203/udp',
  # port => 'somehost​:20203/udp',
  # port => '20203/udp', port => '20204/udp',
  # port => '20203/udp', port => '20203/tcp',
  );
}
exit;

###----------------------------------------------------------------###
### overridden server hooks

### set up some server parameters
sub configure_hook {
  my $self = shift;

  ### change the packet len?
  $self->{server}->{udp_recv_len} = $recv_length; # default is 4096

}

### this is the main method to override
### this is where most of the work will occur
### A sample server is shown below.
sub process_request {
  my $self = shift;
  my $prop = $self->{'server'};

  ### if we were writing a server that did both tcp and udp,
  ### we would need to check $prop->{udp_true} to see
  ### if the current connection is udp or not
  # if ($prop->{udp_true}) {
  # # yup, this is udp
  # }

  # all of the client data is already in 'udp_data'
  if ($prop->{'udp_data'} =~ /dump/) {
  local $Data​::Dumper​::Sortkeys = 1;
  $prop->{'client'}->send(Data​::Dumper​::Dumper($self), 0);
  } else {
  $prop->{'client'}->send("You said \"$prop->{udp_data}\"", 0);
  }
  return;

}

###----------------------------------------------------------------###
### dummy client terminal echo relay

sub handle_client2 {
  require IO​::Socket;

  my $recv_flags = 0;

  print "$0\nEcho server client relay\nType anything and hit enter\n";
  print "-------------------------------\n";
  while (defined(my $line = <STDIN>)) {
  chomp $line;

  my $sock = IO​::Socket​::INET->new(
  PeerAddr => $host,
  PeerPort => $port,
  Proto => 'udp',
  )
  || die "Couldn't connect to $host​:$port​: $!";

  $sock->send($line, 0);

  my $data = '';
  $sock->recv($data, $recv_length, $recv_flags);

  print "From the server​:\n$data\n-------------------------\n";
  }

}

###----------------------------------------------------------------###

sub handle_client {
 
  use threads;
  use threads​::shared;
  use Thread​::Queue;

  $SIG{ALRM} = 'a';
 
  my $q = new Thread​::Queue;
 
  # -- this will be the primary application loop
  # PushData()
  # check and branch on responses
 
  foreach my $i (1 .. 200){
  # here we PullDataSXLRequest() to get our payload until S_OK
  # call again if I_SXL_REQUEST_READY
  # wait and retry if I_BUSY_*
  # fail if anything else
  eval { my $t = threads->create(\&runner2, $host, $port, $q, 80000, $i)->detach(); };
  eval { threads->create(\&subthread, $q, $i)->detach(); };
  }
 
  print STDERR "elements pending​: ", $q->pending, "\n";
  my $count=0;
  my $p;
  while( $p = $q->pending ){
  $count++;
  print STDERR "$p, $count dequeue --->> ", $q->dequeue, "\n";
  }
 
  # application chance to clear up
  foreach my $p (1 .. 20){
  print STDERR ". ";
  sleep(1);
  threads->yield();
  }
}

###----------------------------------------------------------------###

sub subthread(){
  my $q = shift();
  my $count = shift();

  threads->yield();
 
  my $p = $q->pending;
  print STDERR "$p,count​: $count, thr dq --->> ", $q->dequeue, "\n";
}

###----------------------------------------------------------------###

sub runner2(){
  my $host = shift();
  my $port = shift();
  my $queue = shift();
  my $timeout = shift();
  my $count = shift();
 

  my $rand = int(rand(65535));
  if( $rand == $port ){ $rand += 1; }
  if( $rand < 1024 ){ $rand += 1024; }

  my $iaddr = gethostbyname("localhost");
  my $proto = getprotobyname('udp');
  my $paddr = &sockaddr_in(0, $iaddr); # 0 means let kernel pick

  my $SOCKET;

  socket($SOCKET, PF_INET, SOCK_DGRAM, $proto) or die "socket​: $!";
  bind($SOCKET, $paddr) or die "bind​: $!";
 
  my $hisiaddr = inet_aton($host) || die "unknown host";
  my $hispaddr = &sockaddr_in($port, $hisiaddr);
  send($SOCKET, "port $rand", 0, $hispaddr);
  print STDERR time(), " send OK\n";
  my $data = '';
 
  my $recv_flags = MSG_DONTWAIT;
  #my $recv_flags = 0;
  my $respaddr;

 

  eval{

  local $SIG{ALRM} = sub {
  print STDERR time(), " ALRM\n";
  die "alarm time out";
  };
  #setitimer( ITIMER_REAL, $timeout, 0 );
  #setitimer( ITIMER_REAL, 1, 0 );

# local $SIG{ALRM} = sub {
# print STDERR time(), " ALRM\n";
# die "alarm time out"
# };
  ualarm( $timeout );
  #alarm( 1.5 );

  if( $rand % 2 ){
  print STDERR time(), " sleeping $rand\n";
  threads->yield();
  #usleep(400000);
  #select(undef, undef, undef, 10);
  #while(1){threads->yield();}
  }

  fcntl($SOCKET, F_SETFL(), O_NONBLOCK());

  while(1){
  print STDERR time()," recv enter $rand...\n";
 
  my $responseaddr = recv($SOCKET, $data, $recv_length, $recv_flags);
  if( $! == EAGAIN() ){
  threads->yield();
  }
  else{
  ualarm(0);
  last;
  }
  }
  print STDERR time(), " data​: $data, res​: $port, rand​: $rand \n";
  1;
  }or die "recv from ${host}​:${rand} timed out at ", time(), " after $timeout usecs\n";
}

###----------------------------------------------------------------###
# we'll need to pass in the context/packet/handle
# so we know what to return in PushDataXSLTimeout()

sub runner(){
  my $host = shift();
  my $port = shift();
  my $queue = shift();
  my $timeout = shift();
  my $count = shift();
 

  my $recv_flags = MSG_DONTWAIT;
 
  my $rand = int(rand(65535));
  if( $rand == $port ){ $rand += 1; }
  if( $rand < 1024 ){ $rand += 1024; }

  my $s = IO​::Select->new();

  my $sock = IO​::Socket​::INET->new(
  PeerAddr => $host,
  PeerPort => $port,
  Proto => 'udp',
  LocalPort => $rand,
  Timeout => 1,
  )
  || die "Couldn't connect to $host​:$port​: $!";

  $s->add($sock);

  my @​list;
  @​list = $s->can_write(0) ;
  for my $fdd ( @​list ){
  if( $fdd == $sock ){
  print STDERR "count​: $count, can write port $rand\n";
  }
  }

  $sock->send("port $rand", 0);
  my $data = '';
  print STDERR "\n", time(), " Starting rand​: $rand\n";

  eval {
  threads->yield();
  local $SIG{ALRM} = sub {
  print STDERR time(), " ALRM\n";
  die "alarm time out"
  };
  setitimer( ITIMER_REAL, $timeout, 0 );
 
  # random fails
  # if( $rand % 2 ){
  # print STDERR time(), " sleeping $rand\n";
  # #threads->yield();
# usleep(4000000);
# }
 
  my @​list;
  @​list = $s->can_read(0);
  foreach my $fdd ( @​list ){
  if( $fdd == $sock ){
  print STDERR "count​: $count, can read port $rand\n";
  }
  }
 
  my $rin="";
  vec($rin, fileno($sock), 1) = 1;
  my $rout;

  if( my $nfound = select($rout=$rin, undef, undef, 0) ){
  print STDERR "nfound​: $nfound \n";
  }
  $sock->recv($data, $recv_length, $recv_flags) or die "sockrecv​: $!";
  $queue->enqueue($data);
  print STDERR time(), " From the server​:\n$data\n-------------------------\n";
  close($sock);

  #ualarm(0);
 
  # successful response from SXL2 server
  # so here is where we call PushDataSXLResponse()
 
  1;
  } or die "recv from ${host}​:${rand} timed out at ", time(), " after $timeout usecs\n";

  #$s->remove($sock);

 
}

---

Flags​:
  category=library
  severity=high

---

Site configuration information for perl 5.10.0​:

Configured by user at Thu Dec 4 17​:59​:26 GMT 2008.

Summary of my perl5 (revision 5 version 10 subversion 0) configuration​:
  Platform​:
  osname=freebsd, osvers=7.0-release, archname=i386-freebsd-thread-multi
  uname='freebsd freebsd7_simon.eng.sophos 7.0-release freebsd 7.0-release #0​: sun feb 24 19​:59​:52 utc 2008 root@​logan.cse.buffalo.edu​:usrobjusrsrcsysgeneric i386 '
  config_args=''
  hint=recommended, useposix=true, d_sigaction=define
  useithreads=define, usemultiplicity=define
  useperlio=define, d_sfio=undef, uselargefiles=define, usesocks=undef
  use64bitint=undef, use64bitall=undef, uselongdouble=undef
  usemymalloc=n, bincompat5005=undef
  Compiler​:
  cc='cc', ccflags ='-DHAS_FPSETMASK -DHAS_FLOATINGPOINT_H -fno-strict-aliasing -pipe -I/usr/local/include',
  optimize='-O',
  cppflags='-DHAS_FPSETMASK -DHAS_FLOATINGPOINT_H -fno-strict-aliasing -pipe -I/usr/local/include'
  ccversion='', gccversion='4.2.1 20070719 [FreeBSD]', gccosandvers=''
  intsize=4, longsize=4, ptrsize=4, doublesize=8, byteorder=1234
  d_longlong=define, longlongsize=8, d_longdbl=define, longdblsize=12
  ivtype='long', ivsize=4, nvtype='double', nvsize=8, Off_t='off_t', lseeksize=8
  alignbytes=4, prototype=define
  Linker and Libraries​:
  ld='cc', ldflags ='-pthread -Wl,-E -L/usr/local/lib'
  libpth=/usr/lib /usr/local/lib
  libs=-lm -lcrypt
  perllibs=-lm -lcrypt
  libc=, so=so, useshrplib=false, libperl=libperl.a
  gnulibc_version=''
  Dynamic Linking​:
  dlsrc=dl_dlopen.xs, dlext=so, d_dlsymun=undef, ccdlflags=' '
  cccdlflags='-DPIC -fPIC', lddlflags='-shared -L/usr/local/lib'

Locally applied patches​:
 

---

@​INC for perl 5.10.0​:
  /usr/local/lib/perl5/5.10.0/i386-freebsd-thread-multi
  /usr/local/lib/perl5/5.10.0
  /usr/local/lib/perl5/site_perl/5.10.0/i386-freebsd-thread-multi
  /usr/local/lib/perl5/site_perl/5.10.0
  /usr/local/lib/perl5/site_perl/5.8.8
  /usr/local/lib/perl5/site_perl
  .

---

Environment for perl 5.10.0​:
  HOME=/home/user
  LANG (unset)
  LANGUAGE (unset)
  LD_LIBRARY_PATH (unset)
  LOGDIR (unset)
  PATH=/usr/local/bin​:/usr/local/sbin​:/sbin​:/bin​:/usr/sbin​:/usr/bin​:/usr/games​:/home/user/bin
  PERL_BADLANG (unset)
  SHELL=/usr/local/bin/bash

[p5pRT]

From @jkeenan

On Thu Dec 11 05​:34​:06 2008, Simon.Gray@​Sophos.com wrote​:

Is there anyway this report could be reduced to a smaller test case?

If there isn't, then I think this problem will languish unaddressed for
another 4+ years.

Thank you very much.
Jim Keenan

[p5pRT]

The RT System itself - Status changed from 'new' to 'open'

[p5pRT]

From @dcollinsn

Closing this request, because it fails to report an actionable problem. If this is still an issue, please test on a supported version of perl and Time​::HiRes, assemble a minimal test case that reproduces the problem, and open a new ticket. Be sure to explain how you are running the code in question, especially since the code you provided seems to create a server of some type.

--
Respectfully,
Dan Collins

[p5pRT]

@dcollinsn - Status changed from 'open' to 'rejected'