Front page | perl.perl5.porters |
Postings from January 2005
#!perl -w
print "1..3\n";
use strict;
use Config qw(%Config);
use Carp ();
my $base = "t$$";
my $cc = $ENV{CC} || $Config{cc};
my $_so = ".$Config{dlext}";
file("$base.c", <<'EOT');
/* first sample from perlembed.pod */
#include <EXTERN.h> /* from the Perl distribution */
#include <perl.h> /* from the Perl distribution */
static PerlInterpreter *my_perl; /*** The Perl interpreter ***/
int main(int argc, char **argv, char **env)
{
PERL_SYS_INIT3(&argc,&argv,&env);
my_perl = perl_alloc();
perl_construct(my_perl);
PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
perl_parse(my_perl, NULL, argc, argv, (char **)NULL);
perl_run(my_perl);
perl_destruct(my_perl);
perl_free(my_perl);
PERL_SYS_TERM();
}
EOT
run("$cc -o $base $base.c " . trim_space(scalar qx($^X -MExtUtils::Embed -e ccopts -e ldopts)));
run("./$base", "-le", 'print "ok $_" for 1..2');
#run("-ldd", $base);
# XXX more tests on our new $perl
unlink($base, "$base.c");
if ($Config{d_dlopen} eq "define") {
file("lib$base.c", <<'EOT');
#include <EXTERN.h>
#include <perl.h>
extern void
do_main(void)
{
PerlInterpreter *my_perl = perl_alloc();
perl_free(my_perl);
}
EOT
file("$base.c", <<'EOT');
#include <stdio.h>
#include <dlfcn.h>
int
main(int argc, char* argv[])
{
void *handle;
void (*do_main_ptr)(void);
int i;
char *path;
int rounds;
if (argc < 3) {
fprintf(stderr, "Too few arguments\n");
return 1;
}
path = argv[1];
rounds = atoi(argv[2]);
for (i=0; i < rounds; i++) {
printf("# round %d\n", i);
handle = dlopen((char *)path, RTLD_GLOBAL | RTLD_NOW );
if (handle == NULL) {
printf("failed dlopen %s\n",dlerror());
exit(1);
}
do_main_ptr =(void (*)(void))dlsym(handle, "do_main");
if (do_main_ptr != NULL) {
(*do_main_ptr)();
}
else {
fprintf(stderr, "failed to find do_main\n");
return 1;
}
dlclose(handle);
}
fprintf(stdout, "ok 3\n");
return 0;
}
EOT
run("$cc -o lib$base$_so $Config{lddlflags} lib$base.c " . trim_space(scalar qx($^X -MExtUtils::Embed -e ccopts -e ldopts)));
my $libs = "-ldl";
if ($^O eq "hpux") {
# there is no libdl even though the docs says it should be
$libs =~ s/-ldl\s*//;
# avoid that dlopen fails with the:
# "Can't dlopen() a library containing Thread Local Storage:" error
$libs .= " -lpthread" if $Config{perllibs} =~ /-lpthread/;
}
run("$cc -o $base $base.c $libs");
run("./$base ./lib$base$_so 2000");
unlink($base, "$base.c", "lib$base.c", "lib$base$_so");
}
else {
print "ok 3 # skip no dlopen\n";
}
#-------------------------------------------------
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