Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

[CVE-2015-8608] Perl 5.22 VDir::MapPathA/W Out-of-bounds Reads and Buffer Over-reads #15067

Closed
p5pRT opened this issue Nov 28, 2015 · 36 comments

Comments

@p5pRT
Copy link

commented Nov 28, 2015

Migrated from rt.perl.org#126755 (status was 'resolved')

Searchable as RT126755$

@p5pRT

This comment has been minimized.

Copy link
Author

commented Nov 28, 2015

From @AutoSecTools

Perl 5.22 suffers from two out-of-bounds read and multiple small buffer over-read vulnerabilities in the VDir​::MapPathA and VDir​::MapPathW functions that could potentially be exploited to achieve arbitrary code execution. The out-of-bounds read issues exist because the functions in question do not validate that the chr argument passed to DriveIndex, which calculates an index​:

  inline int DriveIndex(char chr)

  {

if (chr == '\\' || chr == '/')

  return ('Z'-'A')+1;

return (chr | 0x20)-'a';

  };

In the VDir​::MapPathA function, DriveIndex is called with a potentially untrusted value, pInName, and the return value is then passed to GetDirA​:

char *VDir​::MapPathA(const char *pInName)

{ /*

  * possiblities -- relative path or absolute path with or without drive letter

  * OR UNC name

  */

  [...]

  if (pInName[1] == '​:') {

[...]

}

else {

  /* relative path with drive letter */

  strcpy(szBuffer, GetDirA(DriveIndex(*pInName)));

  strcat(szBuffer, &pInName[2]);

  if(strlen(szBuffer) > MAX_PATH)

szBuffer[MAX_PATH] = '\0';

  DoGetFullPathNameA(szBuffer, sizeof(szLocalBufferA), szLocalBufferA);

}

  }

  else {

  [...]

  }

  return szLocalBufferA;

}

GetDirA then uses the unbounded index argument to index into dirTableA, a fixed length char pointer array.

  inline const char *GetDirA(int index)

  {

char *ptr = dirTableA[index];

if (!ptr) {

  /* simulate the existence of this drive */

  ptr = szLocalBufferA;

  ptr[0] = 'A' + index;

  ptr[1] = '​:';

  ptr[2] = '\\';

  ptr[3] = 0;

}

return ptr;

  };

In cases where index is attacker controlled, this behavior can be used to read outside of the dirTableA array. This is especially problematic because the value returned is then copied to a fixed length buffer using strcpy​:

strcpy(szBuffer, GetDirA(DriveIndex(*pInName)));

If an attacker can manipulate the layout of memory to trick GetDirA into returning a string larger than szBuffer, a buffer overflow will occur. The issue in VDir​::MapPathW is nearly identical..

Further, multiple small and less critical buffer over-reads exist in both VDir​::MapPathA and VDir​::MapPathW​:

char *VDir​::MapPathA(const char *pInName)

{ /*

  * possiblities -- relative path or absolute path with or without drive letter

  * OR UNC name

  */

  [...]

  if (!length) <<< Check here confirms the buffer is at least of length 2 (including null) before continuing execution.

return (char*)pInName;

  [...]

  if (pInName[1] == '​:') { <<< While technically no over-read can occur here, pInName is a single character, this checks the null terminator.

/* has drive letter */

if (IsPathSep(pInName[2])) { <<<< This could cause an over-read because the string could possibly be of length 2 (including null).

  /* absolute with drive letter */

  DoGetFullPathNameA((char*)pInName, sizeof(szLocalBufferA), szLocalBufferA);

}

else {

  /* relative path with drive letter */

  strcpy(szBuffer, GetDirA(DriveIndex(*pInName)));

  strcat(szBuffer, &pInName[2]); <<<< This could cause an over-read for the same reason.

  if(strlen(szBuffer) > MAX_PATH)

szBuffer[MAX_PATH] = '\0';

  DoGetFullPathNameA(szBuffer, sizeof(szLocalBufferA), szLocalBufferA);

}

  }

  else {

[...]

}

  }

  return szLocalBufferA;

}

To observe the out-of-bounds read vulnerability in VDir​::MapPathA, the following script can be executed while Perl is under a debugger​:

print glob "]​:";

Which will result in an exception similar to the following​:

(f78.1dd8)​: Access violation - code c0000005 (first chance)

First chance exceptions are reported before any exception handling.

This exception may be expected and handled.

eax=0081d62c ebx=0081dae2 ecx=765c7377 edx=7eff3920 esi=0081dae0 edi=0081d62c

eip=747613a0 esp=0081d608 ebp=74744fac iopl=0 nv up ei pl nz na pe nc

cs=0023 ss=002b ds=002b es=002b fs=0053 gs=002b efl=00010206

MSVCR110!strcat+0x71​:

747613a0 8a11 mov dl,byte ptr [ecx] ds​:002b​:765c7377=??

0​:000> k

ChildEBP RetAddr

0081d608 709059ea MSVCR110!strcat+0x71

0081d940 7090688e perl523!VDir​::MapPathA+0xdd

0081d94c 7090e295 perl523!PerlDirMapPathA+0x1f

0081dab4 70906736 perl523!win32_stat+0x6e

0081dac0 72541f60 perl523!PerlLIOLstat+0xd

0081dee4 7254181b Glob!g_lstat+0x72

0081df6c 725415e7 Glob!glob2+0x7a

0081efb0 72541141 Glob!glob0+0x181

0081f7cc 725420e8 Glob!bsd_glob+0x11d

0081f814 72542929 Glob!doglob+0x3f

0081f850 72542391 Glob!csh_glob+0x4a2

0081f894 708a05f4 Glob!iterate+0x1e8

0081f8ac 708cd3d8 perl523!Perl_pp_glob+0x19a

0081f8b8 70871fd8 perl523!Perl_runops_standard+0xc

0081f8cc 70871ef8 perl523!S_run_body+0xdf

0081f938 70908290 perl523!perl_run+0x1e6

0081fb68 00fe1216 perl523!RunPerl+0xbc

0081fba8 76de3744 perl!__tmainCRTStartup+0xfd

0081fbbc 77b7a064 KERNEL32!BaseThreadInitThunk+0x24

0081fc04 77b7a02f ntdll!__RtlUserThreadStart+0x2f

0081fc14 00000000 ntdll!_RtlUserThreadStart+0x1b

To fix the issue, it is recommended that the VDir​::MapPathA and VDir​::MapPathW functions validate the drive letter to ensure no out-of-bounds reads occur, and also check the length of the pInName argument to ensure no buffer over-reads occur. A proposed patch is attached. However, the patch only addresses the issues in VDir​::MapPathA because it was not immediately clear how to hit VDir​::MapPathW for the purpose of testing.

Credit​: John Leitch (john@​autosectools.com), Bryce Darling (darlingbryce@​gmail.com)

@p5pRT

This comment has been minimized.

Copy link
Author

commented Nov 28, 2015

From @AutoSecTools

VDirMapPathA.patch
diff --git a/win32/vdir.h b/win32/vdir.h
index 42c306b..37515f7 100644
--- a/win32/vdir.h
+++ b/win32/vdir.h
@@ -383,6 +383,7 @@ char *VDir::MapPathA(const char *pInName)
      * possiblities -- relative path or absolute path with or without drive letter
      * OR UNC name
      */
+    int driveIndex;
     char szBuffer[(MAX_PATH+1)*2];
     char szlBuf[MAX_PATH+1];
     int length = strlen(pInName);
@@ -402,15 +403,18 @@ char *VDir::MapPathA(const char *pInName)
     }
     /* strlen(pInName) is now <= MAX_PATH */
 
-    if (pInName[1] == ':') {
+    if (length > 1 && pInName[1] == ':') {
 	/* has drive letter */
-	if (IsPathSep(pInName[2])) {
+	if (length > 2 && IsPathSep(pInName[2])) {
 	    /* absolute with drive letter */
 	    DoGetFullPathNameA((char*)pInName, sizeof(szLocalBufferA), szLocalBufferA);
 	}
 	else {
 	    /* relative path with drive letter */
-	    strcpy(szBuffer, GetDirA(DriveIndex(*pInName)));
+        driveIndex = DriveIndex(*pInName);
+        if (driveIndex < 0 || driveIndex >= driveCount)
+            Perl_croak_nocontext("Bad drive letter '%c'", pInName[0]);
+	    strcpy(szBuffer, GetDirA(driveIndex));
 	    strcat(szBuffer, &pInName[2]);
 	    if(strlen(szBuffer) > MAX_PATH)
 		szBuffer[MAX_PATH] = '\0';
@@ -420,7 +424,7 @@ char *VDir::MapPathA(const char *pInName)
     }
     else {
 	/* no drive letter */
-	if (IsPathSep(pInName[1]) && IsPathSep(pInName[0])) {
+	if (length > 1 && IsPathSep(pInName[1]) && IsPathSep(pInName[0])) {
 	    /* UNC name */
 	    DoGetFullPathNameA((char*)pInName, sizeof(szLocalBufferA), szLocalBufferA);
 	}
@p5pRT

This comment has been minimized.

Copy link
Author

commented Dec 1, 2015

From @iabyn

On Sat, Nov 28, 2015 at 04​:30​:57AM -0800, John Leitch wrote​:

Perl 5.22 suffers from two out-of-bounds read and multiple small buffer
over-read vulnerabilities in the VDir​::MapPathA and VDir​::MapPathW
functions that could potentially be exploited to achieve arbitrary code
execution. The out-of-bounds read issues exist because the functions in
question do not validate that the chr argument passed to DriveIndex,
which calculates an index​:

So in summary​:

present in all releases of perl since perl-5.005_02-2346-g7766f13 to
blead, is win32 code that processes file names which start with "X​:..."
where X is a drive number. Many places call this code, eg stat(), glob()
etc, so it's very likely that perl code that accepts attacker-controlled
filenames can be made to pass that attacker-controlled pathname to
VDir​::MapPathA.

Once there, a drive letter X not in the usual A..Z, a..z can cause a
write buffer overflow. Specifically, it does the equivalent of​:

  char szBuffer[...];
  ...
  drive = pathname[0];
  index = (drive | 0x20) - 'a'; /* whoops​: may be < 0 or > max index */
  char *ptr = dirTableA[index]; /* this may be a random pointer now */
  /* copy arbitrary string which may be of arbitrary length and thus may
  * overwrite the end of szBuffer, and put random stuff at the end of
  * the stack */
  strcpy(szBuffer, ptr); /* copying

How dangerous this is consists, I think, of 3 elements​:

1. Is code that already accepts unvalidated pathnames from an attacker
already insecure? Does this make it even less secure?

2. Is the stack smashing dangerous? I don't know much about win32 on
intel. Does the stack still grow downwards? Is there anything below it?
The other vars local to this function are unused by this point so the
donb;t matter. Can the return PC etc be overwritten?

3. Even if the stack itself isn't trashed, is szBuffer[] getting filled
with trash exploitable?

The issues, of not validating string length before doing e.g.
  if (pInName[1] == '​:') { ...}
I suspect are relatively harmless (but I could be wrong).

My gut feeling is that this is a "CVE, create immediate maint releases"
-level issue.

Finally, the attached patch looks good to me.

--
O Unicef Clearasil!
Gibberish and Drivel!
  -- "Bored of the Rings"

@p5pRT

This comment has been minimized.

Copy link
Author

commented Dec 1, 2015

The RT System itself - Status changed from 'new' to 'open'

@p5pRT

This comment has been minimized.

Copy link
Author

commented Dec 1, 2015

From @AutoSecTools

To touch on your three points​:

1) This is largely application specific and dependent on subsequent
operations performed using the path. I could envision scenarios where a
controllable path may be exposed to the attack surface (in a web
application, for example) with the reasonable expectation that arbitrary
code execution may occur as a result.

2) On x86 the stack grows down and call instructions push the return address
on the stack, so it's possible the IP/PC can be controlled using this.
Compiler mitigations such as stack canaries may mitigate this to an extent,
but it cannot be assumed that they will be present in every build.

3) Quickly glancing through code, I don't see any obvious way corrupting
szBuffer[] could be leveraged for purposes of exploitation. It may be worth
dedicating more time, but nothing jumps out.

Regarding the small over-reads, I do not believe them to be exploitable, but
it seemed like they were worth fixing in the event that somewhere down the
line it was proven otherwise.

John

-----Original Message-----
From​: Dave Mitchell via RT
Sent​: Tuesday, December 1, 2015 7​:08 PM
To​: john@​autosectools.com
Subject​: Re​: [perl #126755] Perl 5.22 VDir​::MapPathA/W Out-of-bounds Reads
and Buffer Over-reads

On Sat, Nov 28, 2015 at 04​:30​:57AM -0800, John Leitch wrote​:

Perl 5.22 suffers from two out-of-bounds read and multiple small buffer
over-read vulnerabilities in the VDir​::MapPathA and VDir​::MapPathW
functions that could potentially be exploited to achieve arbitrary code
execution. The out-of-bounds read issues exist because the functions in
question do not validate that the chr argument passed to DriveIndex,
which calculates an index​:

So in summary​:

present in all releases of perl since perl-5.005_02-2346-g7766f13 to
blead, is win32 code that processes file names which start with "X​:..."
where X is a drive number. Many places call this code, eg stat(), glob()
etc, so it's very likely that perl code that accepts attacker-controlled
filenames can be made to pass that attacker-controlled pathname to
VDir​::MapPathA.

Once there, a drive letter X not in the usual A..Z, a..z can cause a
write buffer overflow. Specifically, it does the equivalent of​:

  char szBuffer[...];
  ...
  drive = pathname[0];
  index = (drive | 0x20) - 'a'; /* whoops​: may be < 0 or > max index */
  char *ptr = dirTableA[index]; /* this may be a random pointer now */
  /* copy arbitrary string which may be of arbitrary length and thus may
  * overwrite the end of szBuffer, and put random stuff at the end of
  * the stack */
  strcpy(szBuffer, ptr); /* copying

How dangerous this is consists, I think, of 3 elements​:

1. Is code that already accepts unvalidated pathnames from an attacker
already insecure? Does this make it even less secure?

2. Is the stack smashing dangerous? I don't know much about win32 on
intel. Does the stack still grow downwards? Is there anything below it?
The other vars local to this function are unused by this point so the
donb;t matter. Can the return PC etc be overwritten?

3. Even if the stack itself isn't trashed, is szBuffer[] getting filled
with trash exploitable?

The issues, of not validating string length before doing e.g.
  if (pInName[1] == '​:') { ...}
I suspect are relatively harmless (but I could be wrong).

My gut feeling is that this is a "CVE, create immediate maint releases"
-level issue.

Finally, the attached patch looks good to me.

--
O Unicef Clearasil!
Gibberish and Drivel!
  -- "Bored of the Rings"

@p5pRT

This comment has been minimized.

Copy link
Author

commented Dec 2, 2015

From @rjbs

* Dave Mitchell <davem@​iabyn.com> [2015-12-01T13​:07​:52]

My gut feeling is that this is a "CVE, create immediate maint releases"
-level issue.

Finally, the attached patch looks good to me.

Other thoughts, anyone? If we're gonna do it, I guess I better get started
doin' it.

--
rjbs

@p5pRT

This comment has been minimized.

Copy link
Author

commented Dec 2, 2015

From @tonycoz

On Sat, Nov 28, 2015 at 04​:30​:57AM -0800, John Leitch wrote​:

To fix the issue, it is recommended that the VDir​::MapPathA and
  VDir​::MapPathW functions validate the drive letter to ensure no
  out-of-bounds reads occur, and also check the length of the pInName
  argument to ensure no buffer over-reads occur. A proposed patch is
  attached. However, the patch only addresses the issues in
  VDir​::MapPathA because it was not immediately clear how to hit
  VDir​::MapPathW for the purpose of testing.

It might be possible through Cwd​::chdir(), since that calls
Win32​::GetFullPathName() which can call PerlDir_mapW() which ends up
calling VDir​::MapPathW().

diff --git a/win32/vdir.h b/win32/vdir.h
index 42c306b..37515f7 100644
--- a/win32/vdir.h
+++ b/win32/vdir.h
@​@​ -383,6 +383,7 @​@​ char *VDir​::MapPathA(const char *pInName)
* possiblities -- relative path or absolute path with or without drive letter
* OR UNC name
*/
+ int driveIndex;
char szBuffer[(MAX_PATH+1)*2];
char szlBuf[MAX_PATH+1];
int length = strlen(pInName);
@​@​ -402,15 +403,18 @​@​ char *VDir​::MapPathA(const char *pInName)
}
/* strlen(pInName) is now <= MAX_PATH */

- if (pInName[1] == '​:') {
+ if (length > 1 && pInName[1] == '​:') {
/* has drive letter */
- if (IsPathSep(pInName[2])) {
+ if (length > 2 && IsPathSep(pInName[2])) {
/* absolute with drive letter */
DoGetFullPathNameA((char*)pInName, sizeof(szLocalBufferA), szLocalBufferA);
}
else {
/* relative path with drive letter */
- strcpy(szBuffer, GetDirA(DriveIndex(*pInName)));
+ driveIndex = DriveIndex(*pInName);
+ if (driveIndex < 0 || driveIndex >= driveCount)
+ Perl_croak_nocontext("Bad drive letter '%c'", pInName[0]);

I'm not sure it should croak, perhaps it should just treat the name as
a local filename, so with a current directory of "C​:\FOO" we'd return
"C​:\FOO\]​:" for your chdir example.

Tony

@p5pRT

This comment has been minimized.

Copy link
Author

commented Dec 2, 2015

From @AutoSecTools

I'll take a look to see if I can hit the W functions tonight. As for
prefixing the CWD, it would also be necessary to replace the '​:' with
something as it is an invalid dir/file character on Windows.

-----Original Message-----
From​: Tony Cook via RT
Sent​: Wednesday, December 2, 2015 5​:12 AM
To​: john@​autosectools.com
Subject​: Re​: [perl #126755] Perl 5.22 VDir​::MapPathA/W Out-of-bounds Reads
and Buffer Over-reads

On Sat, Nov 28, 2015 at 04​:30​:57AM -0800, John Leitch wrote​:

To fix the issue, it is recommended that the VDir​::MapPathA and
  VDir​::MapPathW functions validate the drive letter to ensure no
  out-of-bounds reads occur, and also check the length of the pInName
  argument to ensure no buffer over-reads occur. A proposed patch is
  attached. However, the patch only addresses the issues in
  VDir​::MapPathA because it was not immediately clear how to hit
  VDir​::MapPathW for the purpose of testing.

It might be possible through Cwd​::chdir(), since that calls
Win32​::GetFullPathName() which can call PerlDir_mapW() which ends up
calling VDir​::MapPathW().

diff --git a/win32/vdir.h b/win32/vdir.h
index 42c306b..37515f7 100644
--- a/win32/vdir.h
+++ b/win32/vdir.h
@​@​ -383,6 +383,7 @​@​ char *VDir​::MapPathA(const char *pInName)
* possiblities -- relative path or absolute path with or without
drive letter
* OR UNC name
*/
+ int driveIndex;
char szBuffer[(MAX_PATH+1)*2];
char szlBuf[MAX_PATH+1];
int length = strlen(pInName);
@​@​ -402,15 +403,18 @​@​ char *VDir​::MapPathA(const char *pInName)
}
/* strlen(pInName) is now <= MAX_PATH */

- if (pInName[1] == '​:') {
+ if (length > 1 && pInName[1] == '​:') {
/* has drive letter */
- if (IsPathSep(pInName[2])) {
+ if (length > 2 && IsPathSep(pInName[2])) {
/* absolute with drive letter */
DoGetFullPathNameA((char*)pInName, sizeof(szLocalBufferA),
szLocalBufferA);
}
else {
/* relative path with drive letter */
- strcpy(szBuffer, GetDirA(DriveIndex(*pInName)));
+ driveIndex = DriveIndex(*pInName);
+ if (driveIndex < 0 || driveIndex >= driveCount)
+ Perl_croak_nocontext("Bad drive letter '%c'", pInName[0]);

I'm not sure it should croak, perhaps it should just treat the name as
a local filename, so with a current directory of "C​:\FOO" we'd return
"C​:\FOO\]​:" for your chdir example.

Tony

@p5pRT

This comment has been minimized.

Copy link
Author

commented Dec 2, 2015

From @tonycoz

On Wed, Dec 02, 2015 at 10​:38​:01AM +0100, John Leitch wrote​:

I'll take a look to see if I can hit the W functions tonight. As for
prefixing the CWD, it would also be necessary to replace the '​:' with
something as it is an invalid dir/file character on Windows.

Perhaps it should just return the original filename, to avoid
confusion in error messages when the caller gets around to using the
returned value in an API call.

Tony

@p5pRT

This comment has been minimized.

Copy link
Author

commented Dec 3, 2015

From @AutoSecTools

After further testing I was able to hit MapPathW, but not in a manner that
allowed me to fully control pInName, so I was unable to trigger the
vulnerability. Unfortunately I wasn't able to dedicate much time, so that's
not to say it isn't possible, and I'm not comfortable fixing the issue
without the ability to effectively confirm correctness.

That said, attached is an updated patch for MapPathA that returns pInName in
the event the drive letter is invalid.

John

-----Original Message-----
From​: Tony Cook via RT
Sent​: Wednesday, December 2, 2015 12​:02 PM
To​: john@​autosectools.com
Subject​: Re​: [perl #126755] Perl 5.22 VDir​::MapPathA/W Out-of-bounds Reads
and Buffer Over-reads

On Wed, Dec 02, 2015 at 10​:38​:01AM +0100, John Leitch wrote​:

I'll take a look to see if I can hit the W functions tonight. As for
prefixing the CWD, it would also be necessary to replace the '​:' with
something as it is an invalid dir/file character on Windows.

Perhaps it should just return the original filename, to avoid
confusion in error messages when the caller gets around to using the
returned value in an API call.

Tony

@p5pRT

This comment has been minimized.

Copy link
Author

commented Dec 3, 2015

From @AutoSecTools

VDirMapPathA-2.patch
diff --git a/win32/vdir.h b/win32/vdir.h
index 42c306b..e7f31ef 100644
--- a/win32/vdir.h
+++ b/win32/vdir.h
@@ -383,6 +383,7 @@ char *VDir::MapPathA(const char *pInName)
      * possiblities -- relative path or absolute path with or without drive letter
      * OR UNC name
      */
+    int driveIndex;
     char szBuffer[(MAX_PATH+1)*2];
     char szlBuf[MAX_PATH+1];
     int length = strlen(pInName);
@@ -402,15 +403,18 @@ char *VDir::MapPathA(const char *pInName)
     }
     /* strlen(pInName) is now <= MAX_PATH */
 
-    if (pInName[1] == ':') {
+    if (length > 1 && pInName[1] == ':') {
 	/* has drive letter */
-	if (IsPathSep(pInName[2])) {
+	if (length > 2 && IsPathSep(pInName[2])) {
 	    /* absolute with drive letter */
 	    DoGetFullPathNameA((char*)pInName, sizeof(szLocalBufferA), szLocalBufferA);
 	}
 	else {
 	    /* relative path with drive letter */
-	    strcpy(szBuffer, GetDirA(DriveIndex(*pInName)));
+        driveIndex = DriveIndex(*pInName);
+        if (driveIndex < 0 || driveIndex >= driveCount)
+            return (char*)pInName;
+	    strcpy(szBuffer, GetDirA(driveIndex));
 	    strcat(szBuffer, &pInName[2]);
 	    if(strlen(szBuffer) > MAX_PATH)
 		szBuffer[MAX_PATH] = '\0';
@@ -420,7 +424,7 @@ char *VDir::MapPathA(const char *pInName)
     }
     else {
 	/* no drive letter */
-	if (IsPathSep(pInName[1]) && IsPathSep(pInName[0])) {
+	if (length > 1 && IsPathSep(pInName[1]) && IsPathSep(pInName[0])) {
 	    /* UNC name */
 	    DoGetFullPathNameA((char*)pInName, sizeof(szLocalBufferA), szLocalBufferA);
 	}
@p5pRT

This comment has been minimized.

Copy link
Author

commented Dec 13, 2015

From @AutoSecTools

Hi all,

Has there been any movement on this? We'd like to disclose it publicly at
some point in the future.

John

-----Original Message-----
From​: John Leitch
Sent​: Thursday, December 3, 2015 17​:09
To​: perl5-security-report@​perl.org
Subject​: Re​: [perl #126755] Perl 5.22 VDir​::MapPathA/W Out-of-bounds Reads
and Buffer Over-reads

After further testing I was able to hit MapPathW, but not in a manner that
allowed me to fully control pInName, so I was unable to trigger the
vulnerability. Unfortunately I wasn't able to dedicate much time, so that's
not to say it isn't possible, and I'm not comfortable fixing the issue
without the ability to effectively confirm correctness.

That said, attached is an updated patch for MapPathA that returns pInName in
the event the drive letter is invalid.

John

-----Original Message-----
From​: Tony Cook via RT
Sent​: Wednesday, December 2, 2015 12​:02 PM
To​: john@​autosectools.com
Subject​: Re​: [perl #126755] Perl 5.22 VDir​::MapPathA/W Out-of-bounds Reads
and Buffer Over-reads

On Wed, Dec 02, 2015 at 10​:38​:01AM +0100, John Leitch wrote​:

I'll take a look to see if I can hit the W functions tonight. As for
prefixing the CWD, it would also be necessary to replace the '​:' with
something as it is an invalid dir/file character on Windows.

Perhaps it should just return the original filename, to avoid
confusion in error messages when the caller gets around to using the
returned value in an API call.

Tony

@p5pRT

This comment has been minimized.

Copy link
Author

commented Dec 14, 2015

From @tonycoz

On Thu Dec 03 08​:10​:42 2015, john@​autosectools.com wrote​:

After further testing I was able to hit MapPathW, but not in a manner
that
allowed me to fully control pInName, so I was unable to trigger the
vulnerability. Unfortunately I wasn't able to dedicate much time, so
that's
not to say it isn't possible, and I'm not comfortable fixing the issue
without the ability to effectively confirm correctness.

That said, attached is an updated patch for MapPathA that returns
pInName in
the event the drive letter is invalid.

I was thinking something like the attached.

Tony

@p5pRT

This comment has been minimized.

Copy link
Author

commented Dec 14, 2015

From @tonycoz

0001-perl-126755-avoid-invalid-memory-access-in-MapPath-A.patch
From 23863274c685ccdd4ed05c44d0db2e6dbba6a161 Mon Sep 17 00:00:00 2001
From: Tony Cook <tony@develop-help.com>
Date: Mon, 14 Dec 2015 16:27:53 +1100
Subject: [perl #126755] avoid invalid memory access in MapPath[AW]

---
 MANIFEST                  |  1 +
 ext/XS-APItest/APItest.xs |  9 +++++++++
 ext/XS-APItest/t/win32.t  | 34 ++++++++++++++++++++++++++++++++++
 ext/XS-APItest/typemap    | 12 ++++++++++++
 win32/vdir.h              | 22 +++++++++++++++-------
 5 files changed, 71 insertions(+), 7 deletions(-)
 create mode 100644 ext/XS-APItest/t/win32.t

diff --git a/MANIFEST b/MANIFEST
index 2a5a6a3..5d33307 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -4020,6 +4020,7 @@ ext/XS-APItest/t/utf16_to_utf8.t	Test behaviour of utf16_to_utf8{,reversed}
 ext/XS-APItest/t/utf8.t		Tests for code in utf8.c
 ext/XS-APItest/t/weaken.t	XS::APItest: tests for sv_rvweaken() and sv_get_backrefs()
 ext/XS-APItest/t/whichsig.t	XS::APItest: tests for whichsig() and variants
+ext/XS-APItest/t/win32.t	Test Win32 specific APIs
 ext/XS-APItest/t/xs_special_subs_require.t	for require too
 ext/XS-APItest/t/xs_special_subs.t	Test that XS BEGIN/CHECK/INIT/END work
 ext/XS-APItest/t/xsub_h.t	Tests for XSUB.h
diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs
index ebdef68..e91bf5a 100644
--- a/ext/XS-APItest/APItest.xs
+++ b/ext/XS-APItest/APItest.xs
@@ -5517,3 +5517,12 @@ has_backrefs(SV *sv)
     OUTPUT:
         RETVAL
 
+#if defined(WIN32) && defined(PERL_IMPLICIT_SYS)
+
+const char *
+PerlDir_mapA(const char *path)
+
+const WCHAR *
+PerlDir_mapW(const WCHAR *wpath)
+
+#endif
diff --git a/ext/XS-APItest/t/win32.t b/ext/XS-APItest/t/win32.t
new file mode 100644
index 0000000..edc82a1
--- /dev/null
+++ b/ext/XS-APItest/t/win32.t
@@ -0,0 +1,34 @@
+#!perl -w
+use strict;
+use Test::More;
+use XS::APItest;
+use Config;
+
+plan skip_all => "Tests only apply on MSWin32"
+  unless $^O eq "MSWin32";
+
+SKIP:
+{
+    # [perl #126755] previous the bad drive tests would crash
+    $Config{ccflags} =~ /(?:\A|\s)-DPERL_IMPLICIT_SYS\b/
+      or skip "need implicit_sys for this test", 1;
+    eval "use Encode; 1"
+      or skip "Can't load Encode", 1;
+    my $good_drive = "C:";
+    my $result = PerlDir_mapA($good_drive);
+    like($result, qr/^C:\\/i, "check a good drive");
+    my $bad_drive = "]:";
+    $result = PerlDir_mapA($bad_drive);
+    is($result, $bad_drive, "check a bad drive");
+
+    my $wgood_drive = encode("UTF-16LE", $good_drive . "\0");
+    $result = PerlDir_mapW($wgood_drive);
+    like(decode("UTF16-LE", $result), qr/^c:\\/i,
+         "check a good drive (wide)");
+    my $wbad_drive = encode("UTF-16LE", $bad_drive . "\0");
+    $result = PerlDir_mapW($wbad_drive);
+    is(decode("UTF16-LE", $result), "$bad_drive\0",
+       "check a bad drive (wide)");
+}
+
+done_testing();
diff --git a/ext/XS-APItest/typemap b/ext/XS-APItest/typemap
index 035f882..ed86a37 100644
--- a/ext/XS-APItest/typemap
+++ b/ext/XS-APItest/typemap
@@ -1 +1,13 @@
 XS::APItest::PtrTable		T_PTROBJ
+
+const WCHAR *			WPV
+
+INPUT
+
+WPV
+        $var = ($type)SvPV_nolen($arg);
+
+OUTPUT
+
+WPV
+        sv_setpvn($arg, (const char *)($var), sizeof(WCHAR) * (1+wcslen($var)));
diff --git a/win32/vdir.h b/win32/vdir.h
index 42c306b..5ab7764 100644
--- a/win32/vdir.h
+++ b/win32/vdir.h
@@ -383,6 +383,7 @@ char *VDir::MapPathA(const char *pInName)
      * possiblities -- relative path or absolute path with or without drive letter
      * OR UNC name
      */
+    int driveIndex;
     char szBuffer[(MAX_PATH+1)*2];
     char szlBuf[MAX_PATH+1];
     int length = strlen(pInName);
@@ -402,15 +403,18 @@ char *VDir::MapPathA(const char *pInName)
     }
     /* strlen(pInName) is now <= MAX_PATH */
 
-    if (pInName[1] == ':') {
+    if (length > 1 && pInName[1] == ':') {
 	/* has drive letter */
-	if (IsPathSep(pInName[2])) {
+	if (length > 2 && IsPathSep(pInName[2])) {
 	    /* absolute with drive letter */
 	    DoGetFullPathNameA((char*)pInName, sizeof(szLocalBufferA), szLocalBufferA);
 	}
 	else {
 	    /* relative path with drive letter */
-	    strcpy(szBuffer, GetDirA(DriveIndex(*pInName)));
+            driveIndex = DriveIndex(*pInName);
+            if (driveIndex < 0 || driveIndex > driveCount)
+                return (char *)pInName;
+	    strcpy(szBuffer, GetDirA(driveIndex));
 	    strcat(szBuffer, &pInName[2]);
 	    if(strlen(szBuffer) > MAX_PATH)
 		szBuffer[MAX_PATH] = '\0';
@@ -420,7 +424,7 @@ char *VDir::MapPathA(const char *pInName)
     }
     else {
 	/* no drive letter */
-	if (IsPathSep(pInName[1]) && IsPathSep(pInName[0])) {
+	if (length > 1 && IsPathSep(pInName[1]) && IsPathSep(pInName[0])) {
 	    /* UNC name */
 	    DoGetFullPathNameA((char*)pInName, sizeof(szLocalBufferA), szLocalBufferA);
 	}
@@ -611,6 +615,7 @@ WCHAR* VDir::MapPathW(const WCHAR *pInName)
      * possiblities -- relative path or absolute path with or without drive letter
      * OR UNC name
      */
+    int driveIndex;
     WCHAR szBuffer[(MAX_PATH+1)*2];
     WCHAR szlBuf[MAX_PATH+1];
     int length = wcslen(pInName);
@@ -630,7 +635,7 @@ WCHAR* VDir::MapPathW(const WCHAR *pInName)
     }
     /* strlen(pInName) is now <= MAX_PATH */
 
-    if (pInName[1] == ':') {
+    if (length > 1 && pInName[1] == ':') {
 	/* has drive letter */
 	if (IsPathSep(pInName[2])) {
 	    /* absolute with drive letter */
@@ -638,7 +643,10 @@ WCHAR* VDir::MapPathW(const WCHAR *pInName)
 	}
 	else {
 	    /* relative path with drive letter */
-	    wcscpy(szBuffer, GetDirW(DriveIndex((char)*pInName)));
+            driveIndex = DriveIndex(*pInName);
+            if (driveIndex < 0 || driveIndex > driveCount)
+                return (WCHAR *)pInName;
+	    wcscpy(szBuffer, GetDirW(driveIndex));
 	    wcscat(szBuffer, &pInName[2]);
 	    if(wcslen(szBuffer) > MAX_PATH)
 		szBuffer[MAX_PATH] = '\0';
@@ -648,7 +656,7 @@ WCHAR* VDir::MapPathW(const WCHAR *pInName)
     }
     else {
 	/* no drive letter */
-	if (IsPathSep(pInName[1]) && IsPathSep(pInName[0])) {
+	if (length > 1 && IsPathSep(pInName[1]) && IsPathSep(pInName[0])) {
 	    /* UNC name */
 	    DoGetFullPathNameW((WCHAR*)pInName, (sizeof(szLocalBufferW)/sizeof(WCHAR)), szLocalBufferW);
 	}
-- 
1.9.5.msysgit.0

@p5pRT

This comment has been minimized.

Copy link
Author

commented Dec 14, 2015

From @rjbs

* Tony Cook via RT <perl5-security-report@​perl.org> [2015-12-14T00​:44​:28]

I was thinking something like the attached.

I'd appreciate some more eyes on this. Getting this rolled out to vendors
won't (necessarily) be too much of a pain since we only have two Win32 vendors,
but nonetheless there's more to releasing this fix than publishing the patch.

The sooner the patch is favorably reviewed, the sooner we can move forward.

--
rjbs

@p5pRT

This comment has been minimized.

Copy link
Author

commented Dec 15, 2015

From @AutoSecTools

I'm testing this now and I'm still experiencing crashes with the attached
repro. Digging in now to figure it out.

-----Original Message-----
From​: Ricardo Signes via RT
Sent​: Monday, December 14, 2015 23​:54
To​: john@​autosectools.com
Subject​: Re​: [perl #126755] Perl 5.22 VDir​::MapPathA/W Out-of-bounds Reads
and Buffer Over-reads

* Tony Cook via RT <perl5-security-report@​perl.org> [2015-12-14T00​:44​:28]

I was thinking something like the attached.

I'd appreciate some more eyes on this. Getting this rolled out to vendors
won't (necessarily) be too much of a pain since we only have two Win32
vendors,
but nonetheless there's more to releasing this fix than publishing the
patch.

The sooner the patch is favorably reviewed, the sooner we can move forward.

--
rjbs

@p5pRT

This comment has been minimized.

Copy link
Author

commented Dec 15, 2015

@p5pRT

This comment has been minimized.

Copy link
Author

commented Dec 15, 2015

From @AutoSecTools

Attached is an updated patch. The issue was the driveIndex comparison, which
should have been GTE rather than GT.

-----Original Message-----
From​: John Leitch
Sent​: Tuesday, December 15, 2015 18​:42
To​: perl5-security-report@​perl.org
Subject​: Re​: [perl #126755] Perl 5.22 VDir​::MapPathA/W Out-of-bounds Reads
and Buffer Over-reads

I'm testing this now and I'm still experiencing crashes with the attached
repro. Digging in now to figure it out.

-----Original Message-----
From​: Ricardo Signes via RT
Sent​: Monday, December 14, 2015 23​:54
To​: john@​autosectools.com
Subject​: Re​: [perl #126755] Perl 5.22 VDir​::MapPathA/W Out-of-bounds Reads
and Buffer Over-reads

* Tony Cook via RT <perl5-security-report@​perl.org> [2015-12-14T00​:44​:28]

I was thinking something like the attached.

I'd appreciate some more eyes on this. Getting this rolled out to vendors
won't (necessarily) be too much of a pain since we only have two Win32
vendors,
but nonetheless there's more to releasing this fix than publishing the
patch.

The sooner the patch is favorably reviewed, the sooner we can move forward.

--
rjbs

@p5pRT

This comment has been minimized.

Copy link
Author

commented Dec 15, 2015

From @AutoSecTools

0001-perl-126755-avoid-invalid-memory-access-in-MapPath-A-2.patch
diff --git a/MANIFEST b/MANIFEST
index ca2c455..02b6ed4 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -4020,6 +4020,7 @@ ext/XS-APItest/t/utf16_to_utf8.t	Test behaviour of utf16_to_utf8{,reversed}
 ext/XS-APItest/t/utf8.t		Tests for code in utf8.c
 ext/XS-APItest/t/weaken.t	XS::APItest: tests for sv_rvweaken() and sv_get_backrefs()
 ext/XS-APItest/t/whichsig.t	XS::APItest: tests for whichsig() and variants
+ext/XS-APItest/t/win32.t	Test Win32 specific APIs
 ext/XS-APItest/t/xs_special_subs_require.t	for require too
 ext/XS-APItest/t/xs_special_subs.t	Test that XS BEGIN/CHECK/INIT/END work
 ext/XS-APItest/t/xsub_h.t	Tests for XSUB.h
diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs
index efe6da3..24c6625 100644
--- a/ext/XS-APItest/APItest.xs
+++ b/ext/XS-APItest/APItest.xs
@@ -5489,3 +5489,12 @@ has_backrefs(SV *sv)
     OUTPUT:
         RETVAL
 
+#if defined(WIN32) && defined(PERL_IMPLICIT_SYS)
+
+const char *
+PerlDir_mapA(const char *path)
+
+const WCHAR *
+PerlDir_mapW(const WCHAR *wpath)
+
+#endif
diff --git a/ext/XS-APItest/typemap b/ext/XS-APItest/typemap
index 035f882..ed86a37 100644
--- a/ext/XS-APItest/typemap
+++ b/ext/XS-APItest/typemap
@@ -1 +1,13 @@
 XS::APItest::PtrTable		T_PTROBJ
+
+const WCHAR *			WPV
+
+INPUT
+
+WPV
+        $var = ($type)SvPV_nolen($arg);
+
+OUTPUT
+
+WPV
+        sv_setpvn($arg, (const char *)($var), sizeof(WCHAR) * (1+wcslen($var)));
diff --git a/win32/vdir.h b/win32/vdir.h
index 42c306b..a158acf 100644
--- a/win32/vdir.h
+++ b/win32/vdir.h
@@ -383,6 +383,7 @@ char *VDir::MapPathA(const char *pInName)
      * possiblities -- relative path or absolute path with or without drive letter
      * OR UNC name
      */
+    int driveIndex;
     char szBuffer[(MAX_PATH+1)*2];
     char szlBuf[MAX_PATH+1];
     int length = strlen(pInName);
@@ -402,15 +403,18 @@ char *VDir::MapPathA(const char *pInName)
     }
     /* strlen(pInName) is now <= MAX_PATH */
 
-    if (pInName[1] == ':') {
+    if (length > 1 && pInName[1] == ':') {
 	/* has drive letter */
-	if (IsPathSep(pInName[2])) {
+	if (length > 2 && IsPathSep(pInName[2])) {
 	    /* absolute with drive letter */
 	    DoGetFullPathNameA((char*)pInName, sizeof(szLocalBufferA), szLocalBufferA);
 	}
 	else {
 	    /* relative path with drive letter */
-	    strcpy(szBuffer, GetDirA(DriveIndex(*pInName)));
+            driveIndex = DriveIndex(*pInName);
+            if (driveIndex < 0 || driveIndex >= driveCount)
+                return (char *)pInName;
+	    strcpy(szBuffer, GetDirA(driveIndex));
 	    strcat(szBuffer, &pInName[2]);
 	    if(strlen(szBuffer) > MAX_PATH)
 		szBuffer[MAX_PATH] = '\0';
@@ -420,7 +424,7 @@ char *VDir::MapPathA(const char *pInName)
     }
     else {
 	/* no drive letter */
-	if (IsPathSep(pInName[1]) && IsPathSep(pInName[0])) {
+	if (length > 1 && IsPathSep(pInName[1]) && IsPathSep(pInName[0])) {
 	    /* UNC name */
 	    DoGetFullPathNameA((char*)pInName, sizeof(szLocalBufferA), szLocalBufferA);
 	}
@@ -611,6 +615,7 @@ WCHAR* VDir::MapPathW(const WCHAR *pInName)
      * possiblities -- relative path or absolute path with or without drive letter
      * OR UNC name
      */
+    int driveIndex;
     WCHAR szBuffer[(MAX_PATH+1)*2];
     WCHAR szlBuf[MAX_PATH+1];
     int length = wcslen(pInName);
@@ -630,7 +635,7 @@ WCHAR* VDir::MapPathW(const WCHAR *pInName)
     }
     /* strlen(pInName) is now <= MAX_PATH */
 
-    if (pInName[1] == ':') {
+    if (length > 1 && pInName[1] == ':') {
 	/* has drive letter */
 	if (IsPathSep(pInName[2])) {
 	    /* absolute with drive letter */
@@ -638,7 +643,10 @@ WCHAR* VDir::MapPathW(const WCHAR *pInName)
 	}
 	else {
 	    /* relative path with drive letter */
-	    wcscpy(szBuffer, GetDirW(DriveIndex((char)*pInName)));
+            driveIndex = DriveIndex(*pInName);
+            if (driveIndex < 0 || driveIndex >= driveCount)
+                return (WCHAR *)pInName;
+	    wcscpy(szBuffer, GetDirW(driveIndex));
 	    wcscat(szBuffer, &pInName[2]);
 	    if(wcslen(szBuffer) > MAX_PATH)
 		szBuffer[MAX_PATH] = '\0';
@@ -648,7 +656,7 @@ WCHAR* VDir::MapPathW(const WCHAR *pInName)
     }
     else {
 	/* no drive letter */
-	if (IsPathSep(pInName[1]) && IsPathSep(pInName[0])) {
+	if (length > 1 && IsPathSep(pInName[1]) && IsPathSep(pInName[0])) {
 	    /* UNC name */
 	    DoGetFullPathNameW((WCHAR*)pInName, (sizeof(szLocalBufferW)/sizeof(WCHAR)), szLocalBufferW);
 	}
@p5pRT

This comment has been minimized.

Copy link
Author

commented Dec 16, 2015

From @tonycoz

On Tue Dec 15 10​:42​:33 2015, john@​autosectools.com wrote​:

Attached is an updated patch. The issue was the driveIndex comparison,
which
should have been GTE rather than GT.

Actually >= driveCount is incorrect too, though it doesn't allow a crash.

driveCount is 27 ('Z'-'A')+1+1

The attached patch fixes that and adds more extensive tests, including testing for fencepost errors.

Tony

@p5pRT

This comment has been minimized.

Copy link
Author

commented Dec 16, 2015

From @tonycoz

0001-perl-126755-avoid-invalid-memory-access-in-MapPath-A.patch
From 15ea5c11597394535969bdb10aaa5952e47c6b37 Mon Sep 17 00:00:00 2001
From: Tony Cook <tony@develop-help.com>
Date: Wed, 16 Dec 2015 11:13:30 +1100
Subject: [perl #126755] avoid invalid memory access in MapPath[AW]

---
 MANIFEST                  |  1 +
 ext/XS-APItest/APItest.xs |  9 +++++++++
 ext/XS-APItest/t/win32.t  | 39 +++++++++++++++++++++++++++++++++++++++
 ext/XS-APItest/typemap    | 12 ++++++++++++
 win32/vdir.h              | 23 ++++++++++++++++-------
 5 files changed, 77 insertions(+), 7 deletions(-)
 create mode 100644 ext/XS-APItest/t/win32.t

diff --git a/MANIFEST b/MANIFEST
index 2a5a6a3..5d33307 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -4020,6 +4020,7 @@ ext/XS-APItest/t/utf16_to_utf8.t	Test behaviour of utf16_to_utf8{,reversed}
 ext/XS-APItest/t/utf8.t		Tests for code in utf8.c
 ext/XS-APItest/t/weaken.t	XS::APItest: tests for sv_rvweaken() and sv_get_backrefs()
 ext/XS-APItest/t/whichsig.t	XS::APItest: tests for whichsig() and variants
+ext/XS-APItest/t/win32.t	Test Win32 specific APIs
 ext/XS-APItest/t/xs_special_subs_require.t	for require too
 ext/XS-APItest/t/xs_special_subs.t	Test that XS BEGIN/CHECK/INIT/END work
 ext/XS-APItest/t/xsub_h.t	Tests for XSUB.h
diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs
index ebdef68..e91bf5a 100644
--- a/ext/XS-APItest/APItest.xs
+++ b/ext/XS-APItest/APItest.xs
@@ -5517,3 +5517,12 @@ has_backrefs(SV *sv)
     OUTPUT:
         RETVAL
 
+#if defined(WIN32) && defined(PERL_IMPLICIT_SYS)
+
+const char *
+PerlDir_mapA(const char *path)
+
+const WCHAR *
+PerlDir_mapW(const WCHAR *wpath)
+
+#endif
diff --git a/ext/XS-APItest/t/win32.t b/ext/XS-APItest/t/win32.t
new file mode 100644
index 0000000..a8905c2
--- /dev/null
+++ b/ext/XS-APItest/t/win32.t
@@ -0,0 +1,39 @@
+#!perl -w
+use strict;
+use Test::More;
+use XS::APItest;
+use Config;
+
+plan skip_all => "Tests only apply on MSWin32"
+  unless $^O eq "MSWin32";
+
+SKIP:
+{
+    # [perl #126755] previous the bad drive tests would crash
+    $Config{ccflags} =~ /(?:\A|\s)-DPERL_IMPLICIT_SYS\b/
+      or skip "need implicit_sys for this test", 1;
+    eval "use Encode; 1"
+      or skip "Can't load Encode", 1;
+    for my $letter ("A" .. "Z", "a" .. "z") {
+        my $good_drive = $letter . ":";
+        my $result = PerlDir_mapA($good_drive);
+        like($result, qr/^$letter:\\/i, "check good drive $letter");
+
+        my $wgood_drive = encode("UTF-16LE", $good_drive . "\0");
+        $result = PerlDir_mapW($wgood_drive);
+        like(decode("UTF16-LE", $result), qr/^$letter:\\/i,
+             "check a good drive (wide)");
+    }
+    for my $bad ('@', '[', '!', '~', '`', '{') {
+        my $bad_drive = "$bad:";
+        my $result = PerlDir_mapA($bad_drive);
+        is($result, $bad_drive, "check bad drive $bad:");
+
+        my $wbad_drive = encode("UTF-16LE", $bad_drive . "\0");
+        $result = PerlDir_mapW($wbad_drive);
+        is(decode("UTF16-LE", $result), "$bad_drive\0",
+           "check bad drive $bad: (wide)");
+    }
+}
+
+done_testing();
diff --git a/ext/XS-APItest/typemap b/ext/XS-APItest/typemap
index 035f882..ed86a37 100644
--- a/ext/XS-APItest/typemap
+++ b/ext/XS-APItest/typemap
@@ -1 +1,13 @@
 XS::APItest::PtrTable		T_PTROBJ
+
+const WCHAR *			WPV
+
+INPUT
+
+WPV
+        $var = ($type)SvPV_nolen($arg);
+
+OUTPUT
+
+WPV
+        sv_setpvn($arg, (const char *)($var), sizeof(WCHAR) * (1+wcslen($var)));
diff --git a/win32/vdir.h b/win32/vdir.h
index 42c306b..b5c6bc6 100644
--- a/win32/vdir.h
+++ b/win32/vdir.h
@@ -15,6 +15,7 @@
  * and one additional slot for a UNC name
  */
 const int driveCount = ('Z'-'A')+1+1;
+const int driveLetterCount = ('Z'-'A')+1;
 
 class VDir
 {
@@ -383,6 +384,7 @@ char *VDir::MapPathA(const char *pInName)
      * possiblities -- relative path or absolute path with or without drive letter
      * OR UNC name
      */
+    int driveIndex;
     char szBuffer[(MAX_PATH+1)*2];
     char szlBuf[MAX_PATH+1];
     int length = strlen(pInName);
@@ -402,15 +404,18 @@ char *VDir::MapPathA(const char *pInName)
     }
     /* strlen(pInName) is now <= MAX_PATH */
 
-    if (pInName[1] == ':') {
+    if (length > 1 && pInName[1] == ':') {
 	/* has drive letter */
-	if (IsPathSep(pInName[2])) {
+	if (length > 2 && IsPathSep(pInName[2])) {
 	    /* absolute with drive letter */
 	    DoGetFullPathNameA((char*)pInName, sizeof(szLocalBufferA), szLocalBufferA);
 	}
 	else {
 	    /* relative path with drive letter */
-	    strcpy(szBuffer, GetDirA(DriveIndex(*pInName)));
+            driveIndex = DriveIndex(*pInName);
+            if (driveIndex < 0 || driveIndex >= driveLetterCount)
+                return (char *)pInName;
+	    strcpy(szBuffer, GetDirA(driveIndex));
 	    strcat(szBuffer, &pInName[2]);
 	    if(strlen(szBuffer) > MAX_PATH)
 		szBuffer[MAX_PATH] = '\0';
@@ -420,7 +425,7 @@ char *VDir::MapPathA(const char *pInName)
     }
     else {
 	/* no drive letter */
-	if (IsPathSep(pInName[1]) && IsPathSep(pInName[0])) {
+	if (length > 1 && IsPathSep(pInName[1]) && IsPathSep(pInName[0])) {
 	    /* UNC name */
 	    DoGetFullPathNameA((char*)pInName, sizeof(szLocalBufferA), szLocalBufferA);
 	}
@@ -611,6 +616,7 @@ WCHAR* VDir::MapPathW(const WCHAR *pInName)
      * possiblities -- relative path or absolute path with or without drive letter
      * OR UNC name
      */
+    int driveIndex;
     WCHAR szBuffer[(MAX_PATH+1)*2];
     WCHAR szlBuf[MAX_PATH+1];
     int length = wcslen(pInName);
@@ -630,7 +636,7 @@ WCHAR* VDir::MapPathW(const WCHAR *pInName)
     }
     /* strlen(pInName) is now <= MAX_PATH */
 
-    if (pInName[1] == ':') {
+    if (length > 1 && pInName[1] == ':') {
 	/* has drive letter */
 	if (IsPathSep(pInName[2])) {
 	    /* absolute with drive letter */
@@ -638,7 +644,10 @@ WCHAR* VDir::MapPathW(const WCHAR *pInName)
 	}
 	else {
 	    /* relative path with drive letter */
-	    wcscpy(szBuffer, GetDirW(DriveIndex((char)*pInName)));
+            driveIndex = DriveIndex(*pInName);
+            if (driveIndex < 0 || driveIndex >= driveLetterCount)
+                return (WCHAR *)pInName;
+	    wcscpy(szBuffer, GetDirW(driveIndex));
 	    wcscat(szBuffer, &pInName[2]);
 	    if(wcslen(szBuffer) > MAX_PATH)
 		szBuffer[MAX_PATH] = '\0';
@@ -648,7 +657,7 @@ WCHAR* VDir::MapPathW(const WCHAR *pInName)
     }
     else {
 	/* no drive letter */
-	if (IsPathSep(pInName[1]) && IsPathSep(pInName[0])) {
+	if (length > 1 && IsPathSep(pInName[1]) && IsPathSep(pInName[0])) {
 	    /* UNC name */
 	    DoGetFullPathNameW((WCHAR*)pInName, (sizeof(szLocalBufferW)/sizeof(WCHAR)), szLocalBufferW);
 	}
-- 
1.9.5.msysgit.0

@p5pRT

This comment has been minimized.

Copy link
Author

commented Dec 16, 2015

From @AutoSecTools

As an outsider looking in, this seems good to me.

-----Original Message-----
From​: Tony Cook via RT
Sent​: Wednesday, December 16, 2015 01​:17
To​: john@​autosectools.com
Subject​: [perl #126755] Perl 5.22 VDir​::MapPathA/W Out-of-bounds Reads and
Buffer Over-reads

On Tue Dec 15 10​:42​:33 2015, john@​autosectools.com wrote​:

Attached is an updated patch. The issue was the driveIndex comparison,
which
should have been GTE rather than GT.

Actually >= driveCount is incorrect too, though it doesn't allow a crash.

driveCount is 27 ('Z'-'A')+1+1

The attached patch fixes that and adds more extensive tests, including
testing for fencepost errors.

Tony

From 15ea5c11597394535969bdb10aaa5952e47c6b37 Mon Sep 17 00​:00​:00 2001
From​: Tony Cook <tony@​develop-help.com>
Date​: Wed, 16 Dec 2015 11​:13​:30 +1100
Subject​: [perl #126755] avoid invalid memory access in MapPath[AW]


MANIFEST | 1 +
ext/XS-APItest/APItest.xs | 9 +++++++++
ext/XS-APItest/t/win32.t | 39 +++++++++++++++++++++++++++++++++++++++
ext/XS-APItest/typemap | 12 ++++++++++++
win32/vdir.h | 23 ++++++++++++++++-------
5 files changed, 77 insertions(+), 7 deletions(-)
create mode 100644 ext/XS-APItest/t/win32.t

Inline Patch
diff --git a/MANIFEST b/MANIFEST
index 2a5a6a3..5d33307 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -4020,6 +4020,7 @@ ext/XS-APItest/t/utf16_to_utf8.t Test behaviour of 
utf16_to_utf8{,reversed} ext/XS\-APItest/t/utf8\.t Tests for code in utf8\.c ext/XS\-APItest/t/weaken\.t XS​::APItest​: tests for sv\_rvweaken\(\) and sv\_get\_backrefs\(\) ext/XS\-APItest/t/whichsig\.t XS​::APItest​: tests for whichsig\(\) and variants \+ext/XS\-APItest/t/win32\.t Test Win32 specific APIs ext/XS\-APItest/t/xs\_special\_subs\_require\.t for require too ext/XS\-APItest/t/xs\_special\_subs\.t Test that XS BEGIN/CHECK/INIT/END work ext/XS\-APItest/t/xsub\_h\.t Tests for XSUB\.h
Inline Patch
diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs
index ebdef68..e91bf5a 100644
--- a/ext/XS-APItest/APItest.xs
+++ b/ext/XS-APItest/APItest.xs
@@ -5517,3 +5517,12 @@ has_backrefs(SV *sv)
     OUTPUT:
         RETVAL

+#if defined(WIN32) && defined(PERL_IMPLICIT_SYS)
+
+const char *
+PerlDir_mapA(const char *path)
+
+const WCHAR *
+PerlDir_mapW(const WCHAR *wpath)
+
+#endif
diff --git a/ext/XS-APItest/t/win32.t b/ext/XS-APItest/t/win32.t
new file mode 100644
index 0000000..a8905c2
--- /dev/null
+++ b/ext/XS-APItest/t/win32.t
@@ -0,0 +1,39 @@
+#!perl -w
+use strict;
+use Test::More;
+use XS::APItest;
+use Config;
+
+plan skip_all => "Tests only apply on MSWin32"
+  unless $^O eq "MSWin32";
+
+SKIP:
+{
+    # [perl #126755] previous the bad drive tests would crash
+    $Config{ccflags} =~ /(?:\A|\s)-DPERL_IMPLICIT_SYS\b/
+      or skip "need implicit_sys for this test", 1;
+    eval "use Encode; 1"
+      or skip "Can't load Encode", 1;
+    for my $letter ("A" .. "Z", "a" .. "z") {
+        my $good_drive = $letter . ":";
+        my $result = PerlDir_mapA($good_drive);
+        like($result, qr/^$letter:\\/i, "check good drive $letter");
+
+        my $wgood_drive = encode("UTF-16LE", $good_drive . "\0");
+        $result = PerlDir_mapW($wgood_drive);
+        like(decode("UTF16-LE", $result), qr/^$letter:\\/i,
+             "check a good drive (wide)");
+    }
+    for my $bad ('@', '[', '!', '~', '`', '{') {
+        my $bad_drive = "$bad:";
+        my $result = PerlDir_mapA($bad_drive);
+        is($result, $bad_drive, "check bad drive $bad:");
+
+        my $wbad_drive = encode("UTF-16LE", $bad_drive . "\0");
+        $result = PerlDir_mapW($wbad_drive);
+        is(decode("UTF16-LE", $result), "$bad_drive\0",
+           "check bad drive $bad: (wide)");
+    }
+}
+
+done_testing();
diff --git a/ext/XS-APItest/typemap b/ext/XS-APItest/typemap
index 035f882..ed86a37 100644
--- a/ext/XS-APItest/typemap
+++ b/ext/XS-APItest/typemap
@@ -1 +1,13 @@
XS::APItest::PtrTable T_PTROBJ \+ \+const WCHAR \* WPV \+ \+INPUT \+ \+WPV \+ $var = \($type\)SvPV\_nolen\($arg\); \+ \+OUTPUT \+ \+WPV \+ sv\_setpvn\($arg\, \(const char \*\)\($var\)\, sizeof\(WCHAR\) \* \(1\+wcslen\($var\)\)\);
Inline Patch
diff --git a/win32/vdir.h b/win32/vdir.h
index 42c306b..b5c6bc6 100644
--- a/win32/vdir.h
+++ b/win32/vdir.h
@@ -15,6 +15,7 @@
  * and one additional slot for a UNC name
  */
const int driveCount = ('Z'-'A')+1+1; \+const int driveLetterCount = \('Z'\-'A'\)\+1;

class VDir
{
@​@​ -383,6 +384,7 @​@​ char *VDir​::MapPathA(const char *pInName)
  * possiblities -- relative path or absolute path with or without drive
letter
  * OR UNC name
  */
+ int driveIndex;
  char szBuffer[(MAX_PATH+1)*2];
  char szlBuf[MAX_PATH+1];
  int length = strlen(pInName);
@​@​ -402,15 +404,18 @​@​ char *VDir​::MapPathA(const char *pInName)
  }
  /* strlen(pInName) is now <= MAX_PATH */

- if (pInName[1] == '​:') {
+ if (length > 1 && pInName[1] == '​:') {
  /* has drive letter */
- if (IsPathSep(pInName[2])) {
+ if (length > 2 && IsPathSep(pInName[2])) {
  /* absolute with drive letter */
  DoGetFullPathNameA((char*)pInName, sizeof(szLocalBufferA),
szLocalBufferA);
  }
  else {
  /* relative path with drive letter */
- strcpy(szBuffer, GetDirA(DriveIndex(*pInName)));
+ driveIndex = DriveIndex(*pInName);
+ if (driveIndex < 0 || driveIndex >= driveLetterCount)
+ return (char *)pInName;
+ strcpy(szBuffer, GetDirA(driveIndex));
  strcat(szBuffer, &pInName[2]);
  if(strlen(szBuffer) > MAX_PATH)
  szBuffer[MAX_PATH] = '\0';
@​@​ -420,7 +425,7 @​@​ char *VDir​::MapPathA(const char *pInName)
  }
  else {
  /* no drive letter */
- if (IsPathSep(pInName[1]) && IsPathSep(pInName[0])) {
+ if (length > 1 && IsPathSep(pInName[1]) && IsPathSep(pInName[0])) {
  /* UNC name */
  DoGetFullPathNameA((char*)pInName, sizeof(szLocalBufferA),
szLocalBufferA);
  }
@​@​ -611,6 +616,7 @​@​ WCHAR* VDir​::MapPathW(const WCHAR *pInName)
  * possiblities -- relative path or absolute path with or without drive
letter
  * OR UNC name
  */
+ int driveIndex;
  WCHAR szBuffer[(MAX_PATH+1)*2];
  WCHAR szlBuf[MAX_PATH+1];
  int length = wcslen(pInName);
@​@​ -630,7 +636,7 @​@​ WCHAR* VDir​::MapPathW(const WCHAR *pInName)
  }
  /* strlen(pInName) is now <= MAX_PATH */

- if (pInName[1] == '​:') {
+ if (length > 1 && pInName[1] == '​:') {
  /* has drive letter */
  if (IsPathSep(pInName[2])) {
  /* absolute with drive letter */
@​@​ -638,7 +644,10 @​@​ WCHAR* VDir​::MapPathW(const WCHAR *pInName)
  }
  else {
  /* relative path with drive letter */
- wcscpy(szBuffer, GetDirW(DriveIndex((char)*pInName)));
+ driveIndex = DriveIndex(*pInName);
+ if (driveIndex < 0 || driveIndex >= driveLetterCount)
+ return (WCHAR *)pInName;
+ wcscpy(szBuffer, GetDirW(driveIndex));
  wcscat(szBuffer, &pInName[2]);
  if(wcslen(szBuffer) > MAX_PATH)
  szBuffer[MAX_PATH] = '\0';
@​@​ -648,7 +657,7 @​@​ WCHAR* VDir​::MapPathW(const WCHAR *pInName)
  }
  else {
  /* no drive letter */
- if (IsPathSep(pInName[1]) && IsPathSep(pInName[0])) {
+ if (length > 1 && IsPathSep(pInName[1]) && IsPathSep(pInName[0])) {
  /* UNC name */
  DoGetFullPathNameW((WCHAR*)pInName,
(sizeof(szLocalBufferW)/sizeof(WCHAR)), szLocalBufferW);
  }
--
1.9.5.msysgit.0

@p5pRT

This comment has been minimized.

Copy link
Author

commented Dec 18, 2015

From @rjbs

* Tony Cook via RT <perl5-security-report@​perl.org> [2015-12-15T19​:17​:52]

From​: Tony Cook <tony@​develop-help.com>
Date​: Wed, 16 Dec 2015 11​:13​:30 +1100
Subject​: [perl #126755] avoid invalid memory access in MapPath[AW]

I have assigned this issue CVE-2015-8608.

I will notify the Win32 vendors, Strawberry and ActiveState, writing​:

  Perl 5.22 suffers from two out-of-bounds read and multiple small buffer
  over-read vulnerabilities in the VDir​::MapPathA and VDir​::MapPathW
  functions that could potentially be exploited to achieve arbitrary code
  execution.

  These defects have been present since perl-5.005_02-2346-g7766f13, circa
  1999.

  These defects were found and reported by John Leitch of AutoSec Tools.

It was unclear to me whether the patch is the product of Tony Cook, or Tony's
refinement of John's patch.

I'll move this ticket to the perl5 queue when the embargo expires. I was going
to call it two weeks, because it's only two vendors... but it's also Christmas
and New Year's. I'm putting the release date on January 11, unless there are
objections between now and tomorrow at (my) lunchtime, when I plan to send the
above, with patch, to the vendors.

--
rjbs

@p5pRT

This comment has been minimized.

Copy link
Author

commented Dec 18, 2015

From @AutoSecTools

If I'm not mistaken, it is a refinement of my patch. Also, if possible,
please also credit Bryce Darling.

-----Original Message-----
From​: Ricardo Signes via RT
Sent​: Friday, December 18, 2015 01​:52
To​: john@​autosectools.com
Subject​: Re​: [perl #126755] Perl 5.22 VDir​::MapPathA/W Out-of-bounds Reads
and Buffer Over-reads

* Tony Cook via RT <perl5-security-report@​perl.org> [2015-12-15T19​:17​:52]

From​: Tony Cook <tony@​develop-help.com>
Date​: Wed, 16 Dec 2015 11​:13​:30 +1100
Subject​: [perl #126755] avoid invalid memory access in MapPath[AW]

I have assigned this issue CVE-2015-8608.

I will notify the Win32 vendors, Strawberry and ActiveState, writing​:

  Perl 5.22 suffers from two out-of-bounds read and multiple small buffer
  over-read vulnerabilities in the VDir​::MapPathA and VDir​::MapPathW
  functions that could potentially be exploited to achieve arbitrary code
  execution.

  These defects have been present since perl-5.005_02-2346-g7766f13, circa
  1999.

  These defects were found and reported by John Leitch of AutoSec Tools.

It was unclear to me whether the patch is the product of Tony Cook, or
Tony's
refinement of John's patch.

I'll move this ticket to the perl5 queue when the embargo expires. I was
going
to call it two weeks, because it's only two vendors... but it's also
Christmas
and New Year's. I'm putting the release date on January 11, unless there
are
objections between now and tomorrow at (my) lunchtime, when I plan to send
the
above, with patch, to the vendors.

--
rjbs

@p5pRT

This comment has been minimized.

Copy link
Author

commented Dec 18, 2015

From @rjbs

* John Leitch <john@​autosectools.com> [2015-12-17T20​:50​:19]

If I'm not mistaken, it is a refinement of my patch. Also, if possible,
please also credit Bryce Darling.

Happy to. Also of AutoSec?

--
rjbs

@p5pRT

This comment has been minimized.

Copy link
Author

commented Dec 18, 2015

From @AutoSecTools

Yup

-----Original Message-----
From​: Ricardo Signes via RT
Sent​: Friday, December 18, 2015 16​:32
To​: john@​autosectools.com
Subject​: Re​: [perl #126755] Perl 5.22 VDir​::MapPathA/W Out-of-bounds Reads
and Buffer Over-reads

* John Leitch <john@​autosectools.com> [2015-12-17T20​:50​:19]

If I'm not mistaken, it is a refinement of my patch. Also, if possible,
please also credit Bryce Darling.

Happy to. Also of AutoSec?

--
rjbs

@p5pRT

This comment has been minimized.

Copy link
Author

commented Dec 18, 2015

From @rjbs

* Dave Mitchell <davem@​iabyn.com> [2015-12-01T13​:07​:52]

My gut feeling is that this is a "CVE, create immediate maint releases"
-level issue.

I got the CVE. It makes sense to apply the patch to maint branches, and to
urge ActiveState and Strawberry to issue new releases.

Do we *also* want to make a new (say v5.18.5) release? It will help users
building from tarball source releases on Win32, which I imagine is quite a
small number.

I'm not strongly opposed, but I'm also not convinced it's worth the effort.

Anybody else?

--
rjbs

@p5pRT

This comment has been minimized.

Copy link
Author

commented Dec 21, 2015

From @iabyn

On Fri, Dec 18, 2015 at 12​:55​:08PM -0500, Ricardo Signes wrote​:

* Dave Mitchell <davem@​iabyn.com> [2015-12-01T13​:07​:52]

My gut feeling is that this is a "CVE, create immediate maint releases"
-level issue.

I got the CVE. It makes sense to apply the patch to maint branches, and to
urge ActiveState and Strawberry to issue new releases.

Do we *also* want to make a new (say v5.18.5) release? It will help users
building from tarball source releases on Win32, which I imagine is quite a
small number.

I'm not strongly opposed, but I'm also not convinced it's worth the effort.

I don't have any particularly strong opinions. I don't know much about how
ActiveState and the Stawberry Guys do their stuff. Would they push out
patched versions of maint releases?

--
Wesley Crusher gets beaten up by his classmates for being a smarmy git,
and consequently has a go at making some friends of his own age for a
change.
  -- Things That Never Happen in "Star Trek" #18

@p5pRT

This comment has been minimized.

Copy link
Author

commented Dec 22, 2015

From @rjbs

* Dave Mitchell <davem@​iabyn.com> [2015-12-21T06​:25​:51]

I don't have any particularly strong opinions. I don't know much about how
ActiveState and the Stawberry Guys do their stuff. Would they push out
patched versions of maint releases?

Strawberry will, but had trouble applying the patch to maint. I'm going to
have a look at giving them combined patches, although I may need to ask for an
assist. Expect that in the next few hours.

I'd think AS would on their own, but I'll follow up.

--
rjbs

@p5pRT

This comment has been minimized.

Copy link
Author

commented Dec 22, 2015

From @rjbs

* Ricardo Signes <perl.security@​rjbs.manxome.org> [2015-12-17T19​:51​:26]

I have assigned this issue CVE-2015-8608.

I will notify the Win32 vendors, Strawberry and ActiveState, writing​:
[ blah blah blah ]

kmx, maintainer of Strawyberry Perl, notes that this patch does not apply
cleanly to 5.20. I had a look, but the conflicts are beyond what I am
confident in my ability to resolve.

(The patch for CVE-2015-8608 also does not apply, but I can sort that one out
myself.)

kmx has asked me to provide jumbo combined patches for these two issues, which
I am happy to do, if a patch for maint-5.20 can be provided to me ASAP.

--
rjbs

@p5pRT

This comment has been minimized.

Copy link
Author

commented Dec 23, 2015

From @tonycoz

On Tue Dec 22 15​:57​:33 2015, perl.security@​rjbs.manxome.org wrote​:

kmx has asked me to provide jumbo combined patches for these two
issues, which
I am happy to do, if a patch for maint-5.20 can be provided to me
ASAP.

Attached.

Tony

@p5pRT

This comment has been minimized.

Copy link
Author

commented Dec 23, 2015

From @tonycoz

0001-perl-126755-avoid-invalid-memory-access-in-MapPath-A.patch
From e3857c2d31d15c3eb06b1f4348a5a4bdfc3d6b46 Mon Sep 17 00:00:00 2001
From: Tony Cook <tony@develop-help.com>
Date: Wed, 23 Dec 2015 14:58:26 +1100
Subject: [perl #126755] avoid invalid memory access in MapPath[AW]

---
 MANIFEST                  |    1 +
 ext/XS-APItest/APItest.pm |    2 +-
 ext/XS-APItest/APItest.xs |   10 ++++++++++
 ext/XS-APItest/t/win32.t  |   39 +++++++++++++++++++++++++++++++++++++++
 ext/XS-APItest/typemap    |   12 ++++++++++++
 win32/vdir.h              |   23 ++++++++++++++++-------
 6 files changed, 79 insertions(+), 8 deletions(-)
 create mode 100644 ext/XS-APItest/t/win32.t

diff --git a/MANIFEST b/MANIFEST
index da8a493..2fbc0fc 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -4000,6 +4000,7 @@ ext/XS-APItest/t/underscore_length.t	Test find_rundefsv()
 ext/XS-APItest/t/utf16_to_utf8.t	Test behaviour of utf16_to_utf8{,reversed}
 ext/XS-APItest/t/utf8.t		Tests for code in utf8.c
 ext/XS-APItest/t/whichsig.t	XS::APItest: tests for whichsig() and variants
+ext/XS-APItest/t/win32.t	Test Win32 specific APIs
 ext/XS-APItest/t/xs_special_subs_require.t	for require too
 ext/XS-APItest/t/xs_special_subs.t	Test that XS BEGIN/CHECK/INIT/END work
 ext/XS-APItest/t/xsub_h.t	Tests for XSUB.h
diff --git a/ext/XS-APItest/APItest.pm b/ext/XS-APItest/APItest.pm
index 63ea858..ec8bc9e 100644
--- a/ext/XS-APItest/APItest.pm
+++ b/ext/XS-APItest/APItest.pm
@@ -5,7 +5,7 @@ use strict;
 use warnings;
 use Carp;
 
-our $VERSION = '0.60_01';
+our $VERSION = '0.60_02';
 
 require XSLoader;
 
diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs
index 8e78736..79c2264 100644
--- a/ext/XS-APItest/APItest.xs
+++ b/ext/XS-APItest/APItest.xs
@@ -4792,3 +4792,13 @@ test_toTITLE_utf8(SV * p)
         RETVAL = av;
     OUTPUT:
         RETVAL
+
+#if defined(WIN32) && defined(PERL_IMPLICIT_SYS)
+
+const char *
+PerlDir_mapA(const char *path)
+
+const WCHAR *
+PerlDir_mapW(const WCHAR *wpath)
+
+#endif
diff --git a/ext/XS-APItest/t/win32.t b/ext/XS-APItest/t/win32.t
new file mode 100644
index 0000000..a8905c2
--- /dev/null
+++ b/ext/XS-APItest/t/win32.t
@@ -0,0 +1,39 @@
+#!perl -w
+use strict;
+use Test::More;
+use XS::APItest;
+use Config;
+
+plan skip_all => "Tests only apply on MSWin32"
+  unless $^O eq "MSWin32";
+
+SKIP:
+{
+    # [perl #126755] previous the bad drive tests would crash
+    $Config{ccflags} =~ /(?:\A|\s)-DPERL_IMPLICIT_SYS\b/
+      or skip "need implicit_sys for this test", 1;
+    eval "use Encode; 1"
+      or skip "Can't load Encode", 1;
+    for my $letter ("A" .. "Z", "a" .. "z") {
+        my $good_drive = $letter . ":";
+        my $result = PerlDir_mapA($good_drive);
+        like($result, qr/^$letter:\\/i, "check good drive $letter");
+
+        my $wgood_drive = encode("UTF-16LE", $good_drive . "\0");
+        $result = PerlDir_mapW($wgood_drive);
+        like(decode("UTF16-LE", $result), qr/^$letter:\\/i,
+             "check a good drive (wide)");
+    }
+    for my $bad ('@', '[', '!', '~', '`', '{') {
+        my $bad_drive = "$bad:";
+        my $result = PerlDir_mapA($bad_drive);
+        is($result, $bad_drive, "check bad drive $bad:");
+
+        my $wbad_drive = encode("UTF-16LE", $bad_drive . "\0");
+        $result = PerlDir_mapW($wbad_drive);
+        is(decode("UTF16-LE", $result), "$bad_drive\0",
+           "check bad drive $bad: (wide)");
+    }
+}
+
+done_testing();
diff --git a/ext/XS-APItest/typemap b/ext/XS-APItest/typemap
index 035f882..ed86a37 100644
--- a/ext/XS-APItest/typemap
+++ b/ext/XS-APItest/typemap
@@ -1 +1,13 @@
 XS::APItest::PtrTable		T_PTROBJ
+
+const WCHAR *			WPV
+
+INPUT
+
+WPV
+        $var = ($type)SvPV_nolen($arg);
+
+OUTPUT
+
+WPV
+        sv_setpvn($arg, (const char *)($var), sizeof(WCHAR) * (1+wcslen($var)));
diff --git a/win32/vdir.h b/win32/vdir.h
index a4186a1..b922130 100644
--- a/win32/vdir.h
+++ b/win32/vdir.h
@@ -15,6 +15,7 @@
  * and one additional slot for a UNC name
  */
 const int driveCount = ('Z'-'A')+1+1;
+const int driveLetterCount = ('Z'-'A')+1;
 
 class VDir
 {
@@ -383,6 +384,7 @@ char *VDir::MapPathA(const char *pInName)
      * possiblities -- relative path or absolute path with or without drive letter
      * OR UNC name
      */
+    int driveIndex;
     char szBuffer[(MAX_PATH+1)*2];
     char szlBuf[MAX_PATH+1];
     int length = strlen(pInName);
@@ -402,15 +404,18 @@ char *VDir::MapPathA(const char *pInName)
     }
     /* strlen(pInName) is now <= MAX_PATH */
 
-    if (pInName[1] == ':') {
+    if (length > 1 && pInName[1] == ':') {
 	/* has drive letter */
-	if (IsPathSep(pInName[2])) {
+	if (length > 2 && IsPathSep(pInName[2])) {
 	    /* absolute with drive letter */
 	    DoGetFullPathNameA((char*)pInName, sizeof(szLocalBufferA), szLocalBufferA);
 	}
 	else {
 	    /* relative path with drive letter */
-	    strcpy(szBuffer, GetDirA(DriveIndex(*pInName)));
+            driveIndex = DriveIndex(*pInName);
+            if (driveIndex < 0 || driveIndex >= driveLetterCount)
+                return (char *)pInName;
+	    strcpy(szBuffer, GetDirA(driveIndex));
 	    strcat(szBuffer, &pInName[2]);
 	    if(strlen(szBuffer) > MAX_PATH)
 		szBuffer[MAX_PATH] = '\0';
@@ -420,7 +425,7 @@ char *VDir::MapPathA(const char *pInName)
     }
     else {
 	/* no drive letter */
-	if (IsPathSep(pInName[1]) && IsPathSep(pInName[0])) {
+	if (length > 1 && IsPathSep(pInName[1]) && IsPathSep(pInName[0])) {
 	    /* UNC name */
 	    DoGetFullPathNameA((char*)pInName, sizeof(szLocalBufferA), szLocalBufferA);
 	}
@@ -611,6 +616,7 @@ WCHAR* VDir::MapPathW(const WCHAR *pInName)
      * possiblities -- relative path or absolute path with or without drive letter
      * OR UNC name
      */
+    int driveIndex;
     WCHAR szBuffer[(MAX_PATH+1)*2];
     WCHAR szlBuf[MAX_PATH+1];
     int length = wcslen(pInName);
@@ -630,7 +636,7 @@ WCHAR* VDir::MapPathW(const WCHAR *pInName)
     }
     /* strlen(pInName) is now <= MAX_PATH */
 
-    if (pInName[1] == ':') {
+    if (length > 1 && pInName[1] == ':') {
 	/* has drive letter */
 	if (IsPathSep(pInName[2])) {
 	    /* absolute with drive letter */
@@ -638,7 +644,10 @@ WCHAR* VDir::MapPathW(const WCHAR *pInName)
 	}
 	else {
 	    /* relative path with drive letter */
-	    wcscpy(szBuffer, GetDirW(DriveIndex((char)*pInName)));
+            driveIndex = DriveIndex(*pInName);
+            if (driveIndex < 0 || driveIndex >= driveLetterCount)
+                return (WCHAR *)pInName;
+	    wcscpy(szBuffer, GetDirW(driveIndex));
 	    wcscat(szBuffer, &pInName[2]);
 	    if(wcslen(szBuffer) > MAX_PATH)
 		szBuffer[MAX_PATH] = '\0';
@@ -648,7 +657,7 @@ WCHAR* VDir::MapPathW(const WCHAR *pInName)
     }
     else {
 	/* no drive letter */
-	if (IsPathSep(pInName[1]) && IsPathSep(pInName[0])) {
+	if (length > 1 && IsPathSep(pInName[1]) && IsPathSep(pInName[0])) {
 	    /* UNC name */
 	    DoGetFullPathNameW((WCHAR*)pInName, (sizeof(szLocalBufferW)/sizeof(WCHAR)), szLocalBufferW);
 	}
-- 
1.7.3.1.msysgit.0

@p5pRT

This comment has been minimized.

Copy link
Author

commented Jan 11, 2016

From @rjbs

This ticket has been moved to the public queue, the embargo has expired, and patches have been pushed to the main repository.

--
rjbs

@p5pRT

This comment has been minimized.

Copy link
Author

commented Jan 11, 2016

@rjbs - Status changed from 'open' to 'pending release'

@p5pRT

This comment has been minimized.

Copy link
Author

commented May 13, 2016

From @khwilliamson

Thank you for submitting this report. You have helped make Perl better.
 
With the release of Perl 5.24.0 on May 9, 2016, this and 149 other issues have been resolved.

Perl 5.24.0 may be downloaded via https://metacpan.org/release/RJBS/perl-5.24.0

@p5pRT

This comment has been minimized.

Copy link
Author

commented May 13, 2016

@khwilliamson - Status changed from 'pending release' to 'resolved'

@p5pRT p5pRT closed this May 13, 2016
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
Projects
None yet
1 participant
You can’t perform that action at this time.