blib.pm dont shell out to "cmd.exe" on Win32+Win32.pm

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 }
 };

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;
 

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_fetchpvn("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);

dist/PathTools/Cwd.pm

@@ -3,7 +3,7 @@ use strict;
 use Exporter;
 
 
-our $VERSION = '3.92';
+our $VERSION = '3.93';
 my $xs_version = $VERSION;
 $VERSION =~ tr/_//d;
 

dist/PathTools/Cwd.xs

@@ -302,6 +302,7 @@ int Perl_getcwd_sv(pTHX_ SV *sv)
 	/* Some getcwd()s automatically allocate a buffer of the given
 	 * size from the heap if they are given a NULL buffer pointer.
 	 * The problem is that this behaviour is not portable. */
+	/* XXX bug use PerlEnv_get_childdir/PerlEnv_free_childenv all OSes? */
 	if (getcwd(buf, sizeof(buf) - 1)) {
 	    STRLEN len = strlen(buf);
 	    sv_setpvn(sv, buf, len);

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)   \

lib/blib.pm

@@ -39,7 +39,7 @@ Nick Ing-Simmons [email protected]
 use Cwd;
 use File::Spec;
 
-our $VERSION = '1.07';
+our $VERSION = '1.08';
 our $Verbose = 0;
 
 sub import
@@ -52,7 +52,11 @@ 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.
-     chomp($dir = `cd`);
+     if(defined &builtin::getcwd) {
+       $dir = builtin::getcwd();
+     } else {
+       chomp($dir = `cd`);
+     }
  }
  else {
      $dir = getcwd;

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);

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 );

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

pod/perldelta.pod

@@ -123,11 +123,19 @@ XXX Remove this section if F<Porting/corelist-perldelta.pl> did not add any cont
 
 =over 4
 
-=item *
+=item blib.pm
+
+C<blib.pm> was updated from 1.07 to 1.08. Previously when L<Win32.pm|Win32>,
+and only that module, the C<cwd()> was obtained through inefficiently
+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
 
-L<XXX> has been upgraded from version A.xx to B.yy.
+C<builtin.pm> was updated from 0.015 to 0.016.
 
-XXX If there was something important to note about this change, include that here.
+C<builtin::getcwd()> was added as experimental.
 
 =back
 

universal.c

@@ -1131,21 +1131,22 @@ 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;
-    SV *sv = sv_newmortal();
-
     if (items != 0)
         croak_xs_usage(cv, "");
+    EXTEND(SP,1);
+    dXSTARG;
+    PUSHs(TARG);
+    PUTBACK;
 
-    (void)getcwd_sv(sv);
+    (void)getcwd_sv(TARG);
 
-    SvTAINTED_on(sv);
-    PUSHs(sv);
-    XSRETURN(1);
+    SvTAINTED_on(TARG);
+    SvSETMAGIC(TARG);
 }
 
 #endif
@@ -1314,6 +1315,10 @@ struct xsub_details {
     int ix;
 };
 
+#ifdef WIN32
+    XS_EXTERNAL(w32_GetCwd);
+#endif
+
 static const struct xsub_details these_details[] = {
     {"UNIVERSAL::isa", XS_UNIVERSAL_isa, NULL, 0 },
     {"UNIVERSAL::can", XS_UNIVERSAL_can, NULL, 0 },
@@ -1344,6 +1349,11 @@ static const struct xsub_details these_details[] = {
     {"re::regexp_pattern", XS_re_regexp_pattern, "$", 0 },
 #if defined(HAS_GETCWD) && defined(PERL_IS_MINIPERL)
     {"Internals::getcwd", XS_Internals_getcwd, "", 0 },
+#elif defined(WIN32)
+    /* 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 },*/
 #endif
     {"Tie::Hash::NamedCapture::_tie_it", XS_NamedCapture_tie_it, NULL, 0 },
     {"Tie::Hash::NamedCapture::TIEHASH", XS_NamedCapture_TIEHASH, NULL, 0 },

util.c

@@ -4124,6 +4124,7 @@ Perl_getcwd_sv(pTHX_ SV *sv)
         /* Some getcwd()s automatically allocate a buffer of the given
          * size from the heap if they are given a NULL buffer pointer.
          * The problem is that this behaviour is not portable. */
+        /* XXX bug use PerlEnv_get_childdir/PerlEnv_free_childenv all OSes? */
         if (getcwd(buf, sizeof(buf) - 1)) {
             sv_setpv(sv, buf);
             return TRUE;