1#!/usr/bin/perl 2 3BEGIN { 4 if( $ENV{PERL_CORE} ) { 5 chdir 't' if -d 't'; 6 @INC = '../lib'; 7 } 8} 9chdir 't'; 10 11use Config; 12use ExtUtils::Embed; 13use File::Spec; 14use IPC::Cmd qw(can_run); 15 16my $cc = $Config{'cc'}; 17if ( $Config{usecrosscompile} && !can_run($cc) ) { 18 print "1..0 # SKIP Cross-compiling and the target doesn't have $cc"; 19 exit; 20} 21open(my $fh,">embed_test.c") || die "Cannot open embed_test.c:$!"; 22print $fh <DATA>; 23close($fh); 24 25$| = 1; 26print "1..10\n"; 27 28my $cl = ($^O eq 'MSWin32' && $cc eq 'cl'); 29my $skip_exe = $^O eq 'os2' && $Config{ldflags} =~ /(?<!\S)-Zexe\b/; 30my $exe = 'embed_test'; 31$exe .= $Config{'exe_ext'} unless $skip_exe; # Linker will auto-append it 32my $obj = 'embed_test' . $Config{'obj_ext'}; 33my $inc = File::Spec->updir; 34my $lib = File::Spec->updir; 35my $libperl_copied; 36my $testlib; 37my @cmd; 38my (@cmd2) if $^O eq 'VMS'; 39# Don't use ccopts() here as we may want to overwrite an existing 40# perl with a new one with inconsistent header files, meaning 41# the usual value for perl_inc(), which is used by ccopts(), 42# will be wrong. 43if ($^O eq 'VMS') { 44 push(@cmd,$cc,"/Obj=$obj"); 45 my (@incs) = ($inc); 46 my $crazy = ccflags(); 47 if ($crazy =~ s#/inc[^=/]*=([\w\$\_\-\.\[\]\:]+)##i) { 48 push(@incs,$1); 49 } 50 if ($crazy =~ s/-I([a-zA-Z0-9\$\_\-\.\[\]\:]*)//) { 51 push(@incs,$1); 52 } 53 $crazy =~ s#/Obj[^=/]*=[\w\$\_\-\.\[\]\:]+##i; 54 push(@cmd,"/Include=(".join(',',@incs).")"); 55 push(@cmd,$crazy); 56 push(@cmd,"embed_test.c"); 57 58 push(@cmd2,$Config{'ld'}, $Config{'ldflags'}, "/exe=$exe"); 59 push(@cmd2,"$obj,[-]perlshr.opt/opt,[-]perlshr_attr.opt/opt"); 60 61} else { 62 if ($cl) { 63 push(@cmd,$cc,"-Fe$exe"); 64 } 65 else { 66 push(@cmd,$cc,'-o' => $exe); 67 } 68 if ($^O eq 'dec_osf' && !defined $Config{usedl}) { 69 # The -non_shared is needed in case of -Uusedl or otherwise 70 # the test application will try to use libperl.so 71 # instead of libperl.a. 72 push @cmd, "-non_shared"; 73 } 74 75 # XXX DAPM 12/2014: ExtUtils::Embed doesn't seem to provide API access 76 # to $Config{optimize} and so compiles the test code without 77 # optimisation on optimised perls. This causes the compiler to warn 78 # when -D_FORTIFY_SOURCE is in force without -O. For now, just strip 79 # the fortify on optimised builds to avoid the warning. 80 my $ccflags = ccflags(); 81 $ccflags =~ s/-D_FORTIFY_SOURCE=\d+// if $Config{optimize} =~ /-O/; 82 83 push(@cmd, "-I$inc", $ccflags, 'embed_test.c'); 84 if ($^O eq 'MSWin32') { 85 $inc = File::Spec->catdir($inc,'win32'); 86 push(@cmd,"-I$inc"); 87 $inc = File::Spec->catdir($inc,'include'); 88 push(@cmd,"-I$inc"); 89 if ($cc eq 'cl') { 90 push(@cmd,'-link',"-libpath:$lib\\lib\\CORE",$Config{'libperl'},$Config{'libs'}); 91 } 92 else { 93 push(@cmd,"-L$lib",$lib.'\lib\CORE\\'.$Config{'libperl'},$Config{'libc'}); 94 } 95 } 96 elsif ($^O eq 'os390' && $Config{usedl}) { 97 push(@cmd,"-L$lib", ldopts()); 98 } else { # Not MSWin32 or OS/390 (z/OS) dynamic. 99 push(@cmd,"-L$lib",'-lperl'); 100 local $SIG{__WARN__} = sub { 101 warn $_[0] unless $_[0] =~ /No library found for .*perl/ 102 }; 103 push(@cmd, '-Zlinker', '/PM:VIO') # Otherwise puts a warning to STDOUT! 104 if $^O eq 'os2' and $Config{ldflags} =~ /(?<!\S)-Zomf\b/; 105 push(@cmd,ldopts()); 106 } 107 108 if ($^O eq 'aix') { # AIX needs an explicit symbol export list. 109 my ($perl_exp) = grep { -f } qw(perl.exp ../perl.exp); 110 die "where is perl.exp?\n" unless defined $perl_exp; 111 for (@cmd) { 112 s!-bE:(\S+)!-bE:$perl_exp!; 113 } 114 } 115 elsif ($^O eq 'cygwin') { # Cygwin needs no special treatment like below 116 ; 117 } 118 elsif ($Config{'libperl'} !~ /\Alibperl\./) { 119 # Everyone needs libperl copied if it's not found by '-lperl'. 120 $testlib = $Config{'libperl'}; 121 my $srclib = $testlib; 122 $testlib =~ s/.+(?=\.[^.]*)/libperl/; 123 $testlib = File::Spec::->catfile($lib, $testlib); 124 $srclib = File::Spec::->catfile($lib, $srclib); 125 if (-f $srclib) { 126 unlink $testlib if -f $testlib; 127 my $ln_or_cp = $Config{'ln'} || $Config{'cp'}; 128 my $lncmd = "$ln_or_cp $srclib $testlib"; 129 #print "# $lncmd\n"; 130 $libperl_copied = 1 unless system($lncmd); 131 } 132 } 133} 134my $status; 135# On OS/2 the linker will always emit an empty line to STDOUT; filter these 136my $cmd = join ' ', @cmd; 137chomp($cmd); # where is the newline coming from? ldopts()? 138print "# $cmd\n"; 139my @out = `$cmd`; 140$status = $?; 141print "# $_\n" foreach @out; 142 143if ($^O eq 'VMS' && !$status) { 144 print "# @cmd2\n"; 145 $status = system(join(' ',@cmd2)); 146} 147print (($status? 'not ': '')."ok 1\n"); 148 149my $embed_test = File::Spec->catfile(File::Spec->curdir, $exe); 150$embed_test = "run/nodebug $exe" if $^O eq 'VMS'; 151print "# embed_test = $embed_test\n"; 152$status = system($embed_test); 153print (($status? 'not ':'')."ok 10 # system returned $status\n"); 154unlink($exe,"embed_test.c",$obj); 155unlink("$exe.manifest") if $cl and $Config{'ccversion'} =~ /^(\d+)/ and $1 >= 14; 156unlink("$exe$Config{exe_ext}") if $skip_exe; 157unlink("embed_test.map","embed_test.lis") if $^O eq 'VMS'; 158unlink(glob("./*.dll")) if $^O eq 'cygwin'; 159unlink($testlib) if $libperl_copied; 160 161# gcc -g -I.. -L../ -o perl_test perl_test.c -lperl `../perl -I../lib -MExtUtils::Embed -I../ -e ccflags -e ldopts` 162__END__ 163 164/* perl_test.c */ 165 166#include <EXTERN.h> 167#include <perl.h> 168 169#define my_puts(a) if(puts(a) < 0) exit(666) 170 171static const char * cmds [] = { "perl", "-e", "$|=1; print qq[ok 5\\n]; $SIG{__WARN__} = sub { print qq[ok 6\\n] if $_[0] =~ /Unexpected exit/; }; exit 5;", NULL }; 172 173#ifdef PERL_GLOBAL_STRUCT_PRIVATE 174static struct perl_vars *my_plvarsp; 175struct perl_vars* Perl_GetVarsPrivate(void) { return my_plvarsp; } 176#endif 177 178#ifdef NO_ENV_ARRAY_IN_MAIN 179int main(int argc, char **argv) { 180 char **env; 181#else 182int main(int argc, char **argv, char **env) { 183#endif 184 PerlInterpreter *my_perl; 185#ifdef PERL_GLOBAL_STRUCT 186 struct perl_vars *my_vars = init_global_struct(); 187# ifdef PERL_GLOBAL_STRUCT_PRIVATE 188 int veto; 189 190 my_plvarsp = my_vars; 191# endif 192#endif /* PERL_GLOBAL_STRUCT */ 193 194 (void)argc; /* PERL_SYS_INIT3 may #define away their use */ 195 (void)argv; 196 PERL_SYS_INIT3(&argc, &argv, &env); 197 198 my_perl = perl_alloc(); 199 200 my_puts("ok 2"); 201 202 perl_construct(my_perl); 203 PL_exit_flags |= PERL_EXIT_WARN; 204 205 my_puts("ok 3"); 206 207 perl_parse(my_perl, NULL, (sizeof(cmds)/sizeof(char *))-1, (char **)cmds, env); 208 209 my_puts("ok 4"); 210 211 fflush(stdout); 212 213 perl_run(my_perl); 214 215 my_puts("ok 7"); 216 217 perl_destruct(my_perl); 218 219 my_puts("ok 8"); 220 221 perl_free(my_perl); 222 223 my_puts("ok 9"); 224 225 PERL_SYS_TERM(); 226 227#ifdef PERL_GLOBAL_STRUCT 228# ifdef PERL_GLOBAL_STRUCT_PRIVATE 229 veto = my_plvarsp->Gveto_cleanup; 230# endif 231 free_global_struct(my_vars); 232# ifdef PERL_GLOBAL_STRUCT_PRIVATE 233 if (!veto) 234 my_plvarsp = NULL; 235 /* Remember, functions registered with atexit() can run after this point, 236 and may access "global" variables, and hence end up calling 237 Perl_GetVarsPrivate() */ 238#endif 239#endif /* PERL_GLOBAL_STRUCT */ 240 241 return 0; 242} 243