builtin::getcwd WIP

bulk88 · bulk88 · commit 284512f34005 · 2024-10-23T14:26:45.000-04:00
Add builtin::getcwd
diff --git a/builtin.c b/builtin.c
@@ -29,6 +29,12 @@ struct BuiltinFuncDescriptor {
     bool is_experimental;
 };
 
+#ifdef WIN32
+    XS_EXTERNAL(w32_GetCwd);
+#elif defined(HAS_GETCWD)
+    XS_EXTERNAL(XS_Internals_getcwd);
+#endif
+
 #define warn_experimental_builtin(name) S_warn_experimental_builtin(aTHX_ name)
 static void S_warn_experimental_builtin(pTHX_ const char *name)
 {
@@ -640,6 +646,11 @@ static const struct BuiltinFuncDescriptor builtins[] = {
     /* list functions */
     { "indexed",          SHORTVER(5,39), &XS_builtin_indexed,          &ck_builtin_funcN, 0, false },
     { "export_lexically",      NO_BUNDLE, &XS_builtin_export_lexically, NULL,              0, true },
+#ifdef WIN32
+    { "getcwd",        NO_BUNDLE, &w32_GetCwd,           NULL, 0, true },
+#elif defined(HAS_GETCWD)
+    { "getcwd",        NO_BUNDLE, &XS_Internals_getcwd,  NULL, 0, true },
+#endif
 
     { NULL, 0, NULL, NULL, 0, false }
 };
diff --git a/cpan/Win32/Win32.pm b/cpan/Win32/Win32.pm
@@ -8,7 +8,7 @@ package Win32;
     require DynaLoader;
 
     @ISA = qw|Exporter DynaLoader|;
-    $VERSION = '0.59_01';
+    $VERSION = '0.59_04';
     $XS_VERSION = $VERSION;
     $VERSION = eval $VERSION;
 
diff --git a/cpan/Win32/Win32.xs b/cpan/Win32/Win32.xs
@@ -936,31 +936,72 @@ XS(w32_SetChildShowWindow)
 XS(w32_GetCwd)
 {
     dXSARGS;
-    char* ptr;
+    /* Make the host for current directory */
+    char buf [MAX_PATH+1];
+    char* dir;
+    DWORD dirlen;
+    DWORD dirretlen;
+    PH_GCDB_T dirinfo;
+    unsigned int gotutf8;
+    SV * sv;
     if (items)
-	Perl_croak(aTHX_ "usage: Win32::GetCwd()");
+        croak_xs_usage(cv, "");
+    EXTEND(SP,1);
 
-    /* Make the host for current directory */
-    ptr = PerlEnv_get_childdir();
-    /*
-     * If ptr != Nullch
-     *   then it worked, set PV valid,
-     *   else return 'undef'
-     */
-    if (ptr) {
-	SV *sv = sv_newmortal();
-	sv_setpv(sv, ptr);
-	PerlEnv_free_childdir(ptr);
+    dXSTARG;
+    sv = TARG;
 
+    if(SvTYPE(sv) >= SVt_PV) {
+        SV_CHECK_THINKFIRST_COW_DROP(sv);
+        if(SvLEN(sv) >= 32) {
+            dirlen = (DWORD)SvLEN(sv);
+            dir = SvPVX(sv);
+        }
+        else
+          goto stk_buf;
+    }
+    else {
+        stk_buf:
+        dirlen = sizeof(buf);
+        dir = buf;
+    }
+
+    dirinfo.want_wide = 0;
+    dirinfo.want_utf8_maybe = XSANY.any_i32 == 'W' ? 1 : 0;
+
+    retry_dir:
+    dirinfo.len_tchar = dirlen;
+    dirretlen = PerlEnv_get_childdir_tbuf(dir, dirinfo);
+    gotutf8 = dirretlen & 0x80000000;
+    dirretlen &= ~0x80000000;
+    if(dirretlen >=  dirlen) {
+        dirlen = dirretlen + 1;
+        dir = alloca(dirlen);
+        goto retry_dir;
+    }
+    else if(!dirretlen){
+        //translate_to_errno(); //TODO XXXX
+        sv = &PL_sv_undef;
+    }
+    else if(SvTYPE(sv) >= SVt_PV && dir == SvPVX(sv)) {
+        SvCUR_set(sv, dirretlen);
+        SvNIOK_off(sv);
+        SvPOK_on(sv);
+        if(gotutf8)
+          SvUTF8_on(sv);
+        SvSETMAGIC(sv);
+    }
+    else {
+        if(gotutf8)
+            SvUTF8_on(sv);
+        sv_setpvn_mg(sv, dir, dirretlen);
+    }
 #ifndef INCOMPLETE_TAINTS
 	SvTAINTED_on(sv);
 #endif
 
-	EXTEND(SP,1);
-	ST(0) = sv;
-	XSRETURN(1);
-    }
-    XSRETURN_UNDEF;
+    PUSHs(sv);
+    PUTBACK;
 }
 
 XS(w32_SetCwd)
@@ -2023,6 +2064,8 @@ PROTOTYPES: DISABLE
 BOOT:
 {
     const char *file = __FILE__;
+    GV * gv;
+    CV * cv;
 
     if (g_osver.dwOSVersionInfoSize == 0) {
         g_osver.dwOSVersionInfoSize = sizeof(g_osver);
@@ -2051,8 +2094,19 @@ BOOT:
     newXS("Win32::GetFolderPath", w32_GetFolderPath, file);
     newXS("Win32::IsAdminUser", w32_IsAdminUser, file);
     newXS("Win32::GetFileVersion", w32_GetFileVersion, file);
-
-    newXS("Win32::GetCwd", w32_GetCwd, file);
+    gv = gv_fetchpvs("Win32::GetCwd", sizeof("Win32::GetCwd")-1, 0, SVt_PVGV);
+    cv = GvCV(gv);
+    if(cv) {
+        GvCV_set(gv, NULL);
+        SvREFCNT_dec_NN(cv);
+    }
+    cv = newXS("Win32::GetCwdA", w32_GetCwd, file);
+    XSANY.any_i32 = 'A';
+    SvREFCNT_inc(cv);
+    GvCV_set(gv,cv);
+
+    cv = newXS("Win32::GetCwdW", w32_GetCwd, file);
+    XSANY.any_i32 = 'W';
     newXS("Win32::SetCwd", w32_SetCwd, file);
     newXS("Win32::GetNextAvailDrive", w32_GetNextAvailDrive, file);
     newXS("Win32::GetLastError", w32_GetLastError, file);
diff --git a/iperlsys.h b/iperlsys.h
@@ -470,6 +470,7 @@ typedef void*           (*LPEnvGetChildenv)(struct IPerlEnv*);
 typedef void            (*LPEnvFreeChildenv)(struct IPerlEnv*, void* env);
 typedef char*           (*LPEnvGetChilddir)(struct IPerlEnv*);
 typedef void            (*LPEnvFreeChilddir)(struct IPerlEnv*, char* dir);
+typedef unsigned int    (*LPEnvGetChilddir_tbuf)(struct IPerlEnv*, char* ptr, PH_GCDB_T info);
 #  ifdef HAS_ENVGETENV
 typedef char*           (*LPENVGetenv)(struct IPerlEnv*, const char *varname);
 typedef char*           (*LPENVGetenv_len)(struct IPerlEnv*,
@@ -497,6 +498,7 @@ struct IPerlEnv
     LPEnvFreeChildenv   pFreeChildenv;
     LPEnvGetChilddir    pGetChilddir;
     LPEnvFreeChilddir   pFreeChilddir;
+    LPEnvGetChilddir_tbuf    pGetChilddir_tbuf;
 #  ifdef HAS_ENVGETENV
     LPENVGetenv         pENVGetenv;
     LPENVGetenv_len     pENVGetenv_len;
@@ -532,6 +534,8 @@ struct IPerlEnvInfo
         (*PL_Env->pGetChilddir)(PL_Env)
 #  define PerlEnv_free_childdir(d)                              \
         (*PL_Env->pFreeChilddir)(PL_Env, (d))
+#  define PerlEnv_get_childdir_tbuf(_p,_i)                         \
+        (*PL_Env->pGetChilddir_tbuf)(PL_Env,(_p),(_i))
 #  ifdef HAS_ENVGETENV
 #    define PerlEnv_ENVgetenv(str)                              \
         (*PL_Env->pENVGetenv)(PL_Env,(str))
@@ -583,6 +587,7 @@ struct IPerlEnvInfo
 #  define PerlEnv_get_childenv()                win32_get_childenv()
 #  define PerlEnv_free_childenv(e)      win32_free_childenv((e))
 #  define PerlEnv_get_childdir()                win32_get_childdir()
+#  define PerlEnv_get_childdir_tbuf(_p,_i)      win32_get_childdir_tbuf((_p),(_i))
 #  define PerlEnv_free_childdir(d)      win32_free_childdir((d))
 #  else
 #    define PerlEnv_clearenv(str)               (ENV_LOCK, (clearenv(str)   \
diff --git a/lib/Internals.pod b/lib/Internals.pod
@@ -57,22 +57,6 @@ to implement higher-level behavior which should be used instead.
 See the core implementation for the exact meaning of the readonly flag for
 each internal variable type.
 
-=item Internals::getcwd()
-
-Internally core maintained version of L<Cwd::getcwd()|Cwd/getcwd> or
-L<Win32::GetCwd()|Win32/Win32::GetCwd()>. Only for use if loading L<Cwd::|Cwd> or
-calling C<Win32::GetCwd()> and its C<AUTOLOAD> to L<Win32.pm|Win32> will
-somehow break a TAP test in a C<.t>.
-
-Not defined on all platforms and all perl build flag configs.  May not set
-C<PWD> env var.  May disappear at any time.  Probe for the sub's existance
-before calling it and write C<if>/C<else> if C<Internals::getcwd> is
-unavailable.  Although this would be a bug, there is no guarentee it will
-return the same identical string as L<Cwd::getcwd()|Cwd/getcwd> or
-L<Win32::GetCwd()|Win32/Win32::GetCwd()>.  The public implementations can get patched
-in the future for some future discovered bug while this sub keeps the buggy
-return value.
-
 =item hv_clear_placeholders(%hash)
 
 Clear any placeholders from a locked hash. Should not be used directly.
diff --git a/lib/blib.pm b/lib/blib.pm
@@ -52,8 +52,8 @@ sub import
      # That means that it would not be possible to run `make test`
      # for the Win32 module because blib.pm would always load the
      # installed version before @INC gets updated with the blib path.
-     if(defined &Internals::getcwd) {
-       $dir = Internals::getcwd();
+     if(defined &builtin::getcwd) {
+       $dir = builtin::getcwd();
      } else {
        chomp($dir = `cd`);
      }
diff --git a/lib/builtin.pm b/lib/builtin.pm
@@ -1,4 +1,4 @@
-package builtin 0.015;
+package builtin 0.016;
 
 use v5.40;
 
@@ -174,6 +174,29 @@ Returns the floating-point "Not-a-Number" value.
 
 Available starting with Perl 5.40.
 
+=head2 getcwd
+
+    $cwd = builtin::getcwd();
+
+Core maintained version of L<Cwd::getcwd()|Cwd/getcwd> or
+L<Win32::GetCwd()|Win32/Win32::GetCwd()>.  It is suggested that you only use
+this sub if loading L<Cwd::|Cwd> or calling C<Win32::GetCwd()> and its
+C<AUTOLOAD> to L<Win32.pm|Win32> will somehow break a TAP test in a C<.t> or
+for some esoteric reason L<@INC|perlvar/@INC> L<%INC|perlvar/%INC> or
+L<$INC|perlvar/$INC> are unusable or temporarily broken or undef, or you are
+running perl.bin without perl's L<PERL5LIB|perlrun/PERL5LIB> or
+L<PERLLIB|perlrun/PERLLIB>.
+
+C<builtin::getcwd> may not always return the same string as
+L<Cwd::getcwd()|Cwd/getcwd> or L<Win32::GetCwd()|Win32/Win32::GetCwd()>.
+This sub may have less Perl specific OS portability fixes vs the 2
+subs above, and could return C<undef> in situations where those 2 would return
+a successful string value.  C<builtin::getcwd> is not guarenteed to set
+C<PWD> env var.  Although this would be a bug, there is no guarentee it will
+return the same identical string. Note the public implementations of the other
+2 subs can get patched in the future for some future discovered bug while this
+sub keeps the buggy return value string.
+
 =head2 weaken
 
     weaken($ref);
diff --git a/lib/builtin.t b/lib/builtin.t
@@ -440,6 +440,19 @@ TODO: {
     is($HASH{key}, "val", 'Lexically exported hash is accessible');
 }
 
+# Test getcwd
+{
+    require Cwd;
+
+    eval "getcwd()";
+    ok($@, "no main::getcwd");
+
+    TODO: {
+        local $::TODO = "backslash vs forward slash problems on Win32";
+        is(builtin::getcwd(), Cwd::getcwd(), "builtin::getcwd() eq Cwd::getcwd()");
+    }
+}
+
 # load_module
 {
     use builtin qw( load_module );
diff --git a/makedef.pl b/makedef.pl
@@ -347,6 +347,7 @@ sub readvar {
     ++$skip{$_} foreach qw(
 		    Perl_my_popen
 		    Perl_my_pclose
+        win32_get_childdir_tbuf
 			 );
     ++$export{$_} foreach qw(perl_get_host_info perl_alloc_override);
     ++$export{perl_clone_host} if $define{USE_ITHREADS};
@@ -844,6 +845,7 @@ sub readvar {
 		    win32_free_childenv
 		    win32_get_childdir
 		    win32_get_childenv
+		    win32_get_childdir_tbuf
 		    win32_spawnvp
 		    Perl_init_os_extras
 		    Perl_win32_init
diff --git a/pod/perldelta.pod b/pod/perldelta.pod
@@ -131,6 +131,12 @@ shelling out to a new C<cmd.exe>, this was fixed and the C<cwd> when using
 C<blib.pm> and L<Win32.pm|Win32> is obtained with a fast same-process API
 function call the way C<Win32::GetCwd()> and C<Cwd::> do it.
 
+=item builtin.pm
+
+C<builtin.pm> was updated from 0.015 to 0.016.
+
+C<builtin::getcwd()> was added as experimental.
+
 =back
 
 =head2 Removed Modules and Pragmata
@@ -348,12 +354,9 @@ well.
 
 =over 4
 
-=item Internals::getcwd() is documented as very limited platform availability
+=item *
 
-C<Internals::getcwd()> is documented as experimental, unsupported, not-bug-free
-and removeable in the future, and very limited availability on random
-platforms and perl core build flags. Basically C<Win32> only, and only for
-esoteric C<.t> TAP situations and esoteric internal core reasons.
+XXX
 
 =back
 
diff --git a/universal.c b/universal.c
@@ -1131,9 +1131,9 @@ XS(XS_re_regexp_pattern)
     NOT_REACHED; /* NOTREACHED */
 }
 
-#if defined(HAS_GETCWD) && defined(PERL_IS_MINIPERL)
+#if defined(HAS_GETCWD)
 
-XS(XS_Internals_getcwd)
+XS_EXTERNAL(XS_Internals_getcwd)
 {
     dXSARGS;
     if (items != 0)
@@ -1353,7 +1353,7 @@ static const struct xsub_details these_details[] = {
     /* Always offer backup, Win32CORE.c vs AUTOLOAD vs Win32.pm
        vs Win32.dll vs loading a .pm or .dll at all, has rare dep/recursion
        problems in certain modules or .t files. See w32_GetCwd() . */
-    {"Internals::getcwd", w32_GetCwd, "", 0 },
+    /*{"Internals::getcwd", w32_GetCwd, "", 0 },*/
 #endif
     {"Tie::Hash::NamedCapture::_tie_it", XS_NamedCapture_tie_it, NULL, 0 },
     {"Tie::Hash::NamedCapture::TIEHASH", XS_NamedCapture_TIEHASH, NULL, 0 },
diff --git a/win32/perlhost.h b/win32/perlhost.h
diff --git a/win32/vdir.h b/win32/vdir.h
diff --git a/win32/win32.c b/win32/win32.c
diff --git a/win32/win32.h b/win32/win32.h
diff --git a/win32/win32iop.h b/win32/win32iop.h
