Front page | perl.perl5.porters |
Postings from January 2005
#!perl -w
use strict;
use Config qw(%Config);
use Carp ();
unless (($Config{usethreads} || "") eq 'define') {
print "1..0 # Skipped: perl not thread enabled\n";
exit;
}
unless ($Config{perllibs} =~ /-lpthread\b/) {
print "1..0 # Skipped: perl is not using pthreads\n";
exit;
}
print "1..1\n";
my $base = "t$$";
my $cc = $ENV{CC} || $Config{cc};
file("$base.c", <<'EOT');
#include <EXTERN.h> /* from the Perl distribution */
#include <perl.h> /* from the Perl distribution */
#include <pthread.h>
int main(int argc, char **argv, char **env)
{
PerlInterpreter *my_perl;
pthread_key_t key;
/* allocate all the thread keys so that perl don't get one */
while (pthread_key_create(&key, 0) == 0)
; /* empty */
my_perl = perl_alloc();
perl_free(my_perl);
}
EOT
run("$cc -o $base $base.c " . trim_space(scalar qx($^X -MExtUtils::Embed -e ccopts -e ldopts)));
my $out = `./$base 2>&1`;
#print "# $out\n";
unless ($? && $out =~ /^panic: pthread_key_create failed/) {
print "# failed: \$? = $?, output = [$out]\n";
print "not ";
}
print "ok 1\n";
unlink($base, "$base.c");
#-------------------------------------------------
sub trim_space {
my $str = shift;
$str =~ s/^\s+//;
$str =~ s/\s+/ /g;
$str =~ s/\s+\z//;
return $str;
}
sub run {
my @cmds = @_;
my $ignore_err = $cmds[0] =~ s/^-//;
if ($cmds[0] =~ s/^@(-)?//) {
$ignore_err++ if $1;
}
{
my $prefix = "# ";
$prefix = "" unless defined $prefix;
if (@cmds == 1) {
print "$prefix$cmds[0]\n";
}
else {
print $prefix . shell_quote(@cmds) . "\n";
}
}
system(@cmds) == 0 || $ignore_err || do {
my $msg = "Command";
if ($? == -1) {
my $cmd = $cmds[0];
$cmd =~ s/\s.*// if @cmds == 1;
$msg .= qq( "$cmd" failed: $!);
}
else {
# decode $?
my $exit_value = $? >> 8;
my $signal = $? & 127;
my $dumped_core = $? & 128;
$msg .= " exits with $exit_value" if $exit_value;
$msg .= " killed by signal $signal" if $signal;
$msg .= " (core dumped)" if $dumped_core;
}
$msg .= ":\n @cmds\n stopped";
Carp::croak($msg);
};
return $?;
}
sub shell_quote {
my @copy;
for (defined(wantarray) ? (@copy = @_) : @_) {
if ($^O eq "MSWin32") {
s/(\\*)\"/$1$1\\\"/g;
$_ = qq("$_") if /\s/ || $_ eq "";
}
else {
if ($_ eq "" || /[^\w\.\-\/]/) {
s/([\\\$\"\`])/\\$1/g;
$_ = qq("$_");
}
}
}
wantarray ? @copy : join(" ", @copy);
}
sub file {
my $name = shift;
if (@_) {
my $content = shift;
open(my $f, ">", $name) || die "Can't create '$name': $!";
binmode($f);
print $f $content;
close($f) || die "Can't write to '$name': $!";
}
else {
open(my $f, "<", $name) || return undef;
binmode($f);
local $/;
return scalar <$f>;
}
}
Thread Next