This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
perl.c change to use HAS_PROCSELFEXE, also
authorNick Ing-Simmons <nik@tiuk.ti.com>
Tue, 20 Nov 2001 20:01:05 +0000 (20:01 +0000)
committerNick Ing-Simmons <nik@tiuk.ti.com>
Tue, 20 Nov 2001 20:01:05 +0000 (20:01 +0000)
tweak to $^X test to comprehend full path to real executable
being returned (like Cygwin as it happens...)

p4raw-id: //depot/perlio@13138

perl.c
t/op/magic.t

diff --git a/perl.c b/perl.c
index 710ae84..4b3eb60 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -2777,8 +2777,8 @@ sed %s -e \"/^[^#]/b\" \
        }
 #endif /* IAMSUID */
 
        }
 #endif /* IAMSUID */
 
-        DEBUG_P(PerlIO_printf(Perl_debug_log, 
-                              "PL_preprocess: cmd=\"%s\"\n", 
+        DEBUG_P(PerlIO_printf(Perl_debug_log,
+                              "PL_preprocess: cmd=\"%s\"\n",
                               SvPVX(cmd)));
 
        PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
                               SvPVX(cmd)));
 
        PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
@@ -3419,6 +3419,24 @@ Perl_init_argv_symbols(pTHX_ register int argc, register char **argv)
     }
 }
 
     }
 }
 
+#ifdef HAS_PROCSELFEXE
+/* This is a function so that we don't hold on to MAXPATHLEN
+   bytes of stack longer than necessary
+ */
+STATIC void
+S_procself_val(pTHX_ SV *sv, char *arg0)
+{
+    char buf[MAXPATHLEN];
+    int len = readlink("/proc/self/exe", buf, sizeof(buf) - 1);
+    if (len > 0) {
+       sv_setpvn(sv,buf,len);
+    }
+    else {
+       sv_setpv(sv,arg0);
+    }
+}
+#endif /* HAS_PROCSELFEXE */
+
 STATIC void
 S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
 {
 STATIC void
 S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
 {
@@ -3451,12 +3469,17 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register
        magicname("0", "0", 1);
 #endif
     }
        magicname("0", "0", 1);
 #endif
     }
-    if ((tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))) /* $^X */
+    if ((tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))) {/* $^X */
+#ifdef HAS_PROCSELFEXE
+       S_procself_val(aTHX_ GvSV(tmpgv), PL_origargv[0]);
+#else
 #ifdef OS2
        sv_setpv(GvSV(tmpgv), os2_execname(aTHX));
 #else
        sv_setpv(GvSV(tmpgv),PL_origargv[0]);
 #endif
 #ifdef OS2
        sv_setpv(GvSV(tmpgv), os2_execname(aTHX));
 #else
        sv_setpv(GvSV(tmpgv),PL_origargv[0]);
 #endif
+#endif
+    }
     if ((PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV))) {
        HV *hv;
        GvMULTI_on(PL_envgv);
     if ((PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV))) {
        HV *hv;
        GvMULTI_on(PL_envgv);
index 73dc8a6..4e47414 100755 (executable)
@@ -8,6 +8,7 @@ BEGIN {
 }
 
 use warnings;
 }
 
 use warnings;
+use Config;
 
 my $test = 1;
 sub ok {
 
 my $test = 1;
 sub ok {
@@ -71,7 +72,7 @@ if ($Is_MSWin32 || $Is_NetWare || $Is_Dos || $Is_MPE || $Is_MacOS) {
 else {
   # the next tests are done in a subprocess because sh spits out a
   # newline onto stderr when a child process kills itself with SIGINT.
 else {
   # the next tests are done in a subprocess because sh spits out a
   # newline onto stderr when a child process kills itself with SIGINT.
-  # We use a pipe rather than system() because the VMS command buffer 
+  # We use a pipe rather than system() because the VMS command buffer
   # would overflow with a command that long.
 
     open( CMDPIPE, "| $PERL");
   # would overflow with a command that long.
 
     open( CMDPIPE, "| $PERL");
@@ -148,7 +149,7 @@ ok $$ > 0, $$;
     if ($^O eq 'qnx') {
        chomp($wd = `/usr/bin/fullpath -t`);
     }
     if ($^O eq 'qnx') {
        chomp($wd = `/usr/bin/fullpath -t`);
     }
-    elsif($Is_Cygwin) {
+    elsif($Is_Cygwin || $Config{'d_procselfexe'}) {
        # Cygwin turns the symlink into the real file
        chomp($wd = `pwd`);
        $wd =~ s#/t$##;
        # Cygwin turns the symlink into the real file
        chomp($wd = `pwd`);
        $wd =~ s#/t$##;