1 #define WIN32_LEAN_AND_MEAN
2 #define _WIN32_WINNT 0x0500
3 #include <wchar.h>
4 #include <wctype.h>
5 #include <windows.h>
6 #include <shlobj.h>
7 #include <wchar.h>
8 #include <userenv.h>
9 #include <lm.h>
10 #if !defined(__GNUC__) || (((100000 * __GNUC__) + (1000 * __GNUC_MINOR__)) >= 408000)
11 # include <winhttp.h>
12 #endif
13
14 #define PERL_NO_GET_CONTEXT
15 #include "EXTERN.h"
16 #include "perl.h"
17 #include "XSUB.h"
18
19 #ifndef countof
20 # define countof(array) (sizeof (array) / sizeof (*(array)))
21 #endif
22
23 #define SE_SHUTDOWN_NAMEA "SeShutdownPrivilege"
24
25 #ifndef WC_NO_BEST_FIT_CHARS
26 # define WC_NO_BEST_FIT_CHARS 0x00000400
27 #endif
28
29 #define GETPROC(fn) pfn##fn = (PFN##fn)GetProcAddress(module, #fn)
30
31 typedef int (__stdcall *PFNDllRegisterServer)(void);
32 typedef int (__stdcall *PFNDllUnregisterServer)(void);
33 typedef BOOL (__stdcall *PFNIsUserAnAdmin)(void);
34 typedef BOOL (WINAPI *PFNGetProductInfo)(DWORD, DWORD, DWORD, DWORD, DWORD*);
35 typedef void (WINAPI *PFNGetNativeSystemInfo)(LPSYSTEM_INFO lpSystemInfo);
36 typedef LONG (WINAPI *PFNRegGetValueA)(HKEY, LPCSTR, LPCSTR, DWORD, LPDWORD, PVOID, LPDWORD);
37
38 #ifndef CSIDL_MYMUSIC
39 # define CSIDL_MYMUSIC 0x000D
40 #endif
41 #ifndef CSIDL_MYVIDEO
42 # define CSIDL_MYVIDEO 0x000E
43 #endif
44 #ifndef CSIDL_LOCAL_APPDATA
45 # define CSIDL_LOCAL_APPDATA 0x001C
46 #endif
47 #ifndef CSIDL_COMMON_FAVORITES
48 # define CSIDL_COMMON_FAVORITES 0x001F
49 #endif
50 #ifndef CSIDL_INTERNET_CACHE
51 # define CSIDL_INTERNET_CACHE 0x0020
52 #endif
53 #ifndef CSIDL_COOKIES
54 # define CSIDL_COOKIES 0x0021
55 #endif
56 #ifndef CSIDL_HISTORY
57 # define CSIDL_HISTORY 0x0022
58 #endif
59 #ifndef CSIDL_COMMON_APPDATA
60 # define CSIDL_COMMON_APPDATA 0x0023
61 #endif
62 #ifndef CSIDL_WINDOWS
63 # define CSIDL_WINDOWS 0x0024
64 #endif
65 #ifndef CSIDL_PROGRAM_FILES
66 # define CSIDL_PROGRAM_FILES 0x0026
67 #endif
68 #ifndef CSIDL_MYPICTURES
69 # define CSIDL_MYPICTURES 0x0027
70 #endif
71 #ifndef CSIDL_PROFILE
72 # define CSIDL_PROFILE 0x0028
73 #endif
74 #ifndef CSIDL_PROGRAM_FILES_COMMON
75 # define CSIDL_PROGRAM_FILES_COMMON 0x002B
76 #endif
77 #ifndef CSIDL_COMMON_TEMPLATES
78 # define CSIDL_COMMON_TEMPLATES 0x002D
79 #endif
80 #ifndef CSIDL_COMMON_DOCUMENTS
81 # define CSIDL_COMMON_DOCUMENTS 0x002E
82 #endif
83 #ifndef CSIDL_COMMON_ADMINTOOLS
84 # define CSIDL_COMMON_ADMINTOOLS 0x002F
85 #endif
86 #ifndef CSIDL_ADMINTOOLS
87 # define CSIDL_ADMINTOOLS 0x0030
88 #endif
89 #ifndef CSIDL_COMMON_MUSIC
90 # define CSIDL_COMMON_MUSIC 0x0035
91 #endif
92 #ifndef CSIDL_COMMON_PICTURES
93 # define CSIDL_COMMON_PICTURES 0x0036
94 #endif
95 #ifndef CSIDL_COMMON_VIDEO
96 # define CSIDL_COMMON_VIDEO 0x0037
97 #endif
98 #ifndef CSIDL_CDBURN_AREA
99 # define CSIDL_CDBURN_AREA 0x003B
100 #endif
101 #ifndef CSIDL_FLAG_CREATE
102 # define CSIDL_FLAG_CREATE 0x8000
103 #endif
104
105 /* Use explicit struct definition because wSuiteMask and
106 * wProductType are not defined in the VC++ 6.0 headers.
107 * WORD type has been replaced by unsigned short because
108 * WORD is already used by Perl itself.
109 */
110 struct g_osver_t {
111 DWORD dwOSVersionInfoSize;
112 DWORD dwMajorVersion;
113 DWORD dwMinorVersion;
114 DWORD dwBuildNumber;
115 DWORD dwPlatformId;
116 CHAR szCSDVersion[128];
117 unsigned short wServicePackMajor;
118 unsigned short wServicePackMinor;
119 unsigned short wSuiteMask;
120 BYTE wProductType;
121 BYTE wReserved;
122 } g_osver = {0, 0, 0, 0, 0, "", 0, 0, 0, 0, 0};
123 BOOL g_osver_ex = TRUE;
124
125 #define ONE_K_BUFSIZE 1024
126
127 /* Convert SV to wide character string. The return value must be
128 * freed using Safefree().
129 */
130 WCHAR*
sv_to_wstr(pTHX_ SV * sv)131 sv_to_wstr(pTHX_ SV *sv)
132 {
133 DWORD wlen;
134 WCHAR *wstr;
135 STRLEN len;
136 char *str = SvPV(sv, len);
137 UINT cp = SvUTF8(sv) ? CP_UTF8 : CP_ACP;
138
139 wlen = MultiByteToWideChar(cp, 0, str, (int)(len+1), NULL, 0);
140 New(0, wstr, wlen, WCHAR);
141 MultiByteToWideChar(cp, 0, str, (int)(len+1), wstr, wlen);
142
143 return wstr;
144 }
145
146 /* Convert wide character string to mortal SV. Use UTF8 encoding
147 * if the string cannot be represented in the system codepage.
148 */
149 SV *
wstr_to_sv(pTHX_ WCHAR * wstr)150 wstr_to_sv(pTHX_ WCHAR *wstr)
151 {
152 int wlen = (int)wcslen(wstr)+1;
153 BOOL use_default = FALSE;
154 int len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, wstr, wlen, NULL, 0, NULL, NULL);
155 SV *sv = sv_2mortal(newSV(len));
156
157 len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, wstr, wlen, SvPVX(sv), len, NULL, &use_default);
158 if (use_default) {
159 len = WideCharToMultiByte(CP_UTF8, 0, wstr, wlen, NULL, 0, NULL, NULL);
160 sv_grow(sv, len);
161 len = WideCharToMultiByte(CP_UTF8, 0, wstr, wlen, SvPVX(sv), len, NULL, NULL);
162 SvUTF8_on(sv);
163 }
164 /* Shouldn't really ever fail since we ask for the required length first, but who knows... */
165 if (len) {
166 SvPOK_on(sv);
167 SvCUR_set(sv, len-1);
168 }
169 return sv;
170 }
171
172 /* Retrieve a variable from the Unicode environment in a mortal SV.
173 *
174 * Recreates the Unicode environment because a bug in earlier Perl versions
175 * overwrites it with the ANSI version, which contains replacement
176 * characters for the characters not in the ANSI codepage.
177 */
178 SV*
get_unicode_env(pTHX_ const WCHAR * name)179 get_unicode_env(pTHX_ const WCHAR *name)
180 {
181 SV *sv = NULL;
182 void *env;
183 HANDLE token;
184
185 /* Get security token for the current process owner */
186 if (!OpenProcessToken(GetCurrentProcess(), TOKEN_QUERY | TOKEN_DUPLICATE, &token))
187 {
188 return NULL;
189 }
190
191 /* Create a Unicode environment block for this process */
192 if (CreateEnvironmentBlock(&env, token, FALSE))
193 {
194 size_t name_len = wcslen(name);
195 WCHAR *entry = (WCHAR *)env;
196 while (*entry) {
197 size_t i;
198 size_t entry_len = wcslen(entry);
199 BOOL equal = (entry_len > name_len) && (entry[name_len] == '=');
200
201 for (i=0; equal && i < name_len; ++i)
202 equal = (towupper(entry[i]) == towupper(name[i]));
203
204 if (equal) {
205 sv = wstr_to_sv(aTHX_ entry+name_len+1);
206 break;
207 }
208 entry += entry_len+1;
209 }
210 DestroyEnvironmentBlock(env);
211 }
212 CloseHandle(token);
213 return sv;
214 }
215
216 #define CHAR_T WCHAR
217 #define WIN32_FIND_DATA_T WIN32_FIND_DATAW
218 #define FN_FINDFIRSTFILE FindFirstFileW
219 #define FN_STRLEN wcslen
220 #define FN_STRCPY wcscpy
221 #define LONGPATH my_longpathW
222 #include "longpath.inc"
223
224 /* The my_ansipath() function takes a Unicode filename and converts it
225 * into the current Windows codepage. If some characters cannot be mapped,
226 * then it will convert the short name instead.
227 *
228 * The buffer to the ansi pathname must be freed with Safefree() when it
229 * it no longer needed.
230 *
231 * The argument to my_ansipath() must exist before this function is
232 * called; otherwise there is no way to determine the short path name.
233 *
234 * Ideas for future refinement:
235 * - Only convert those segments of the path that are not in the current
236 * codepage, but leave the other segments in their long form.
237 * - If the resulting name is longer than MAX_PATH, start converting
238 * additional path segments into short names until the full name
239 * is shorter than MAX_PATH. Shorten the filename part last!
240 */
241
242 /* This is a modified version of core Perl win32/win32.c(win32_ansipath).
243 * It uses New() etc. instead of win32_malloc().
244 */
245
246 char *
my_ansipath(const WCHAR * widename)247 my_ansipath(const WCHAR *widename)
248 {
249 char *name;
250 BOOL use_default = FALSE;
251 int widelen = (int)wcslen(widename)+1;
252 int len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, widename, widelen,
253 NULL, 0, NULL, NULL);
254 New(0, name, len, char);
255 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, widename, widelen,
256 name, len, NULL, &use_default);
257 if (use_default) {
258 DWORD shortlen = GetShortPathNameW(widename, NULL, 0);
259 if (shortlen) {
260 WCHAR *shortname;
261 New(0, shortname, shortlen, WCHAR);
262 shortlen = GetShortPathNameW(widename, shortname, shortlen)+1;
263
264 len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, shortname, shortlen,
265 NULL, 0, NULL, NULL);
266 Renew(name, len, char);
267 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, shortname, shortlen,
268 name, len, NULL, NULL);
269 Safefree(shortname);
270 }
271 }
272 return name;
273 }
274
275 /* Convert wide character path to ANSI path and return as mortal SV. */
276 SV*
wstr_to_ansipath(pTHX_ WCHAR * wstr)277 wstr_to_ansipath(pTHX_ WCHAR *wstr)
278 {
279 char *ansi = my_ansipath(wstr);
280 SV *sv = sv_2mortal(newSVpvn(ansi, strlen(ansi)));
281 Safefree(ansi);
282 return sv;
283 }
284
285 #ifdef __CYGWIN__
286
287 char*
get_childdir(void)288 get_childdir(void)
289 {
290 dTHX;
291 WCHAR filename[MAX_PATH+1];
292
293 GetCurrentDirectoryW(MAX_PATH+1, filename);
294 return my_ansipath(filename);
295 }
296
297 void
free_childdir(char * d)298 free_childdir(char *d)
299 {
300 dTHX;
301 Safefree(d);
302 }
303
304 void*
get_childenv(void)305 get_childenv(void)
306 {
307 return NULL;
308 }
309
310 void
free_childenv(void * d)311 free_childenv(void *d)
312 {
313 PERL_UNUSED_ARG(d);
314 }
315
316 # define PerlDir_mapA(dir) (dir)
317
318 #endif
319
XS(w32_ExpandEnvironmentStrings)320 XS(w32_ExpandEnvironmentStrings)
321 {
322 dXSARGS;
323 WCHAR value[31*1024];
324 WCHAR *source;
325
326 if (items != 1)
327 croak("usage: Win32::ExpandEnvironmentStrings($String)");
328
329 source = sv_to_wstr(aTHX_ ST(0));
330 ExpandEnvironmentStringsW(source, value, countof(value)-1);
331 ST(0) = wstr_to_sv(aTHX_ value);
332 Safefree(source);
333 XSRETURN(1);
334 }
335
XS(w32_IsAdminUser)336 XS(w32_IsAdminUser)
337 {
338 dXSARGS;
339 HMODULE module;
340 PFNIsUserAnAdmin pfnIsUserAnAdmin;
341 HANDLE hTok;
342 DWORD dwTokInfoLen;
343 TOKEN_GROUPS *lpTokInfo;
344 SID_IDENTIFIER_AUTHORITY NtAuth = SECURITY_NT_AUTHORITY;
345 PSID pAdminSid;
346 int iRetVal;
347 unsigned int i;
348
349 if (items)
350 croak("usage: Win32::IsAdminUser()");
351
352 /* Use IsUserAnAdmin() when available. On Vista this will only return TRUE
353 * if the process is running with elevated privileges and not just when the
354 * process owner is a member of the "Administrators" group.
355 */
356 module = GetModuleHandleA("shell32.dll");
357 GETPROC(IsUserAnAdmin);
358 if (pfnIsUserAnAdmin) {
359 EXTEND(SP, 1);
360 ST(0) = sv_2mortal(newSViv(pfnIsUserAnAdmin() ? 1 : 0));
361 XSRETURN(1);
362 }
363
364 if (!OpenThreadToken(GetCurrentThread(), TOKEN_QUERY, FALSE, &hTok)) {
365 if (!OpenProcessToken(GetCurrentProcess(), TOKEN_QUERY, &hTok)) {
366 warn("Cannot open thread token or process token");
367 XSRETURN_UNDEF;
368 }
369 }
370
371 GetTokenInformation(hTok, TokenGroups, NULL, 0, &dwTokInfoLen);
372 if (!New(1, lpTokInfo, dwTokInfoLen, TOKEN_GROUPS)) {
373 warn("Cannot allocate token information structure");
374 CloseHandle(hTok);
375 XSRETURN_UNDEF;
376 }
377
378 if (!GetTokenInformation(hTok, TokenGroups, lpTokInfo, dwTokInfoLen,
379 &dwTokInfoLen))
380 {
381 warn("Cannot get token information");
382 Safefree(lpTokInfo);
383 CloseHandle(hTok);
384 XSRETURN_UNDEF;
385 }
386
387 if (!AllocateAndInitializeSid(&NtAuth, 2, SECURITY_BUILTIN_DOMAIN_RID,
388 DOMAIN_ALIAS_RID_ADMINS, 0, 0, 0, 0, 0, 0, &pAdminSid))
389 {
390 warn("Cannot allocate administrators' SID");
391 Safefree(lpTokInfo);
392 CloseHandle(hTok);
393 XSRETURN_UNDEF;
394 }
395
396 iRetVal = 0;
397 for (i = 0; i < lpTokInfo->GroupCount; ++i) {
398 if (EqualSid(lpTokInfo->Groups[i].Sid, pAdminSid)) {
399 iRetVal = 1;
400 break;
401 }
402 }
403
404 FreeSid(pAdminSid);
405 Safefree(lpTokInfo);
406 CloseHandle(hTok);
407
408 EXTEND(SP, 1);
409 ST(0) = sv_2mortal(newSViv(iRetVal));
410 XSRETURN(1);
411 }
412
XS(w32_LookupAccountName)413 XS(w32_LookupAccountName)
414 {
415 dXSARGS;
416 char SID[400];
417 DWORD SIDLen;
418 SID_NAME_USE snu;
419 char Domain[256];
420 DWORD DomLen;
421 BOOL bResult;
422
423 if (items != 5)
424 croak("usage: Win32::LookupAccountName($system, $account, $domain, "
425 "$sid, $sidtype)");
426
427 SIDLen = sizeof(SID);
428 DomLen = sizeof(Domain);
429
430 bResult = LookupAccountNameA(SvPV_nolen(ST(0)), /* System */
431 SvPV_nolen(ST(1)), /* Account name */
432 &SID, /* SID structure */
433 &SIDLen, /* Size of SID buffer */
434 Domain, /* Domain buffer */
435 &DomLen, /* Domain buffer size */
436 &snu); /* SID name type */
437 if (bResult) {
438 sv_setpv(ST(2), Domain);
439 sv_setpvn(ST(3), SID, SIDLen);
440 sv_setiv(ST(4), snu);
441 XSRETURN_YES;
442 }
443 XSRETURN_NO;
444 }
445
446
XS(w32_LookupAccountSID)447 XS(w32_LookupAccountSID)
448 {
449 dXSARGS;
450 PSID sid;
451 char Account[256];
452 DWORD AcctLen = sizeof(Account);
453 char Domain[256];
454 DWORD DomLen = sizeof(Domain);
455 SID_NAME_USE snu;
456 BOOL bResult;
457
458 if (items != 5)
459 croak("usage: Win32::LookupAccountSID($system, $sid, $account, $domain, $sidtype)");
460
461 sid = SvPV_nolen(ST(1));
462 if (IsValidSid(sid)) {
463 bResult = LookupAccountSidA(SvPV_nolen(ST(0)), /* System */
464 sid, /* SID structure */
465 Account, /* Account name buffer */
466 &AcctLen, /* name buffer length */
467 Domain, /* Domain buffer */
468 &DomLen, /* Domain buffer length */
469 &snu); /* SID name type */
470 if (bResult) {
471 sv_setpv(ST(2), Account);
472 sv_setpv(ST(3), Domain);
473 sv_setiv(ST(4), (IV)snu);
474 XSRETURN_YES;
475 }
476 }
477 XSRETURN_NO;
478 }
479
XS(w32_InitiateSystemShutdown)480 XS(w32_InitiateSystemShutdown)
481 {
482 dXSARGS;
483 HANDLE hToken; /* handle to process token */
484 TOKEN_PRIVILEGES tkp; /* pointer to token structure */
485 BOOL bRet;
486 char *machineName, *message;
487
488 if (items != 5)
489 croak("usage: Win32::InitiateSystemShutdown($machineName, $message, "
490 "$timeOut, $forceClose, $reboot)");
491
492 machineName = SvPV_nolen(ST(0));
493
494 if (OpenProcessToken(GetCurrentProcess(),
495 TOKEN_ADJUST_PRIVILEGES | TOKEN_QUERY,
496 &hToken))
497 {
498 LookupPrivilegeValueA(machineName,
499 SE_SHUTDOWN_NAMEA,
500 &tkp.Privileges[0].Luid);
501
502 tkp.PrivilegeCount = 1; /* only setting one */
503 tkp.Privileges[0].Attributes = SE_PRIVILEGE_ENABLED;
504
505 /* Get shutdown privilege for this process. */
506 AdjustTokenPrivileges(hToken, FALSE, &tkp, 0,
507 (PTOKEN_PRIVILEGES)NULL, 0);
508 }
509
510 message = SvPV_nolen(ST(1));
511 bRet = InitiateSystemShutdownA(machineName, message, (DWORD)SvIV(ST(2)),
512 (BOOL)SvIV(ST(3)), (BOOL)SvIV(ST(4)));
513
514 /* Disable shutdown privilege. */
515 tkp.Privileges[0].Attributes = 0;
516 AdjustTokenPrivileges(hToken, FALSE, &tkp, 0,
517 (PTOKEN_PRIVILEGES)NULL, 0);
518 CloseHandle(hToken);
519 XSRETURN_IV(bRet);
520 }
521
XS(w32_AbortSystemShutdown)522 XS(w32_AbortSystemShutdown)
523 {
524 dXSARGS;
525 HANDLE hToken; /* handle to process token */
526 TOKEN_PRIVILEGES tkp; /* pointer to token structure */
527 BOOL bRet;
528 char *machineName;
529
530 if (items != 1)
531 croak("usage: Win32::AbortSystemShutdown($machineName)");
532
533 machineName = SvPV_nolen(ST(0));
534
535 if (OpenProcessToken(GetCurrentProcess(),
536 TOKEN_ADJUST_PRIVILEGES | TOKEN_QUERY,
537 &hToken))
538 {
539 LookupPrivilegeValueA(machineName,
540 SE_SHUTDOWN_NAMEA,
541 &tkp.Privileges[0].Luid);
542
543 tkp.PrivilegeCount = 1; /* only setting one */
544 tkp.Privileges[0].Attributes = SE_PRIVILEGE_ENABLED;
545
546 /* Get shutdown privilege for this process. */
547 AdjustTokenPrivileges(hToken, FALSE, &tkp, 0,
548 (PTOKEN_PRIVILEGES)NULL, 0);
549 }
550
551 bRet = AbortSystemShutdownA(machineName);
552
553 /* Disable shutdown privilege. */
554 tkp.Privileges[0].Attributes = 0;
555 AdjustTokenPrivileges(hToken, FALSE, &tkp, 0,
556 (PTOKEN_PRIVILEGES)NULL, 0);
557 CloseHandle(hToken);
558 XSRETURN_IV(bRet);
559 }
560
561
XS(w32_MsgBox)562 XS(w32_MsgBox)
563 {
564 dXSARGS;
565 DWORD flags = MB_ICONEXCLAMATION;
566 I32 result;
567 WCHAR *title = NULL, *msg;
568
569 if (items < 1 || items > 3)
570 croak("usage: Win32::MsgBox($message [, $flags [, $title]])");
571
572 msg = sv_to_wstr(aTHX_ ST(0));
573 if (items > 1)
574 flags = (DWORD)SvIV(ST(1));
575 if (items > 2)
576 title = sv_to_wstr(aTHX_ ST(2));
577
578 result = MessageBoxW(GetActiveWindow(), msg, title ? title : L"Perl", flags);
579
580 Safefree(msg);
581 if (title)
582 Safefree(title);
583
584 XSRETURN_IV(result);
585 }
586
XS(w32_LoadLibrary)587 XS(w32_LoadLibrary)
588 {
589 dXSARGS;
590 HANDLE hHandle;
591
592 if (items != 1)
593 croak("usage: Win32::LoadLibrary($libname)\n");
594 hHandle = LoadLibraryA(SvPV_nolen(ST(0)));
595 #ifdef _WIN64
596 XSRETURN_IV((DWORD_PTR)hHandle);
597 #else
598 XSRETURN_IV((DWORD)hHandle);
599 #endif
600 }
601
XS(w32_FreeLibrary)602 XS(w32_FreeLibrary)
603 {
604 dXSARGS;
605
606 if (items != 1)
607 croak("usage: Win32::FreeLibrary($handle)\n");
608 if (FreeLibrary(INT2PTR(HINSTANCE, SvIV(ST(0))))) {
609 XSRETURN_YES;
610 }
611 XSRETURN_NO;
612 }
613
XS(w32_GetProcAddress)614 XS(w32_GetProcAddress)
615 {
616 dXSARGS;
617
618 if (items != 2)
619 croak("usage: Win32::GetProcAddress($hinstance, $procname)\n");
620 XSRETURN_IV(PTR2IV(GetProcAddress(INT2PTR(HINSTANCE, SvIV(ST(0))), SvPV_nolen(ST(1)))));
621 }
622
XS(w32_RegisterServer)623 XS(w32_RegisterServer)
624 {
625 dXSARGS;
626 BOOL result = FALSE;
627 HMODULE module;
628
629 if (items != 1)
630 croak("usage: Win32::RegisterServer($libname)\n");
631
632 module = LoadLibraryA(SvPV_nolen(ST(0)));
633 if (module) {
634 PFNDllRegisterServer pfnDllRegisterServer;
635 GETPROC(DllRegisterServer);
636 if (pfnDllRegisterServer && pfnDllRegisterServer() == 0)
637 result = TRUE;
638 FreeLibrary(module);
639 }
640 ST(0) = boolSV(result);
641 XSRETURN(1);
642 }
643
XS(w32_UnregisterServer)644 XS(w32_UnregisterServer)
645 {
646 dXSARGS;
647 BOOL result = FALSE;
648 HINSTANCE module;
649
650 if (items != 1)
651 croak("usage: Win32::UnregisterServer($libname)\n");
652
653 module = LoadLibraryA(SvPV_nolen(ST(0)));
654 if (module) {
655 PFNDllUnregisterServer pfnDllUnregisterServer;
656 GETPROC(DllUnregisterServer);
657 if (pfnDllUnregisterServer && pfnDllUnregisterServer() == 0)
658 result = TRUE;
659 FreeLibrary(module);
660 }
661 ST(0) = boolSV(result);
662 XSRETURN(1);
663 }
664
665 /* XXX rather bogus */
XS(w32_GetArchName)666 XS(w32_GetArchName)
667 {
668 dXSARGS;
669 if (items)
670 Perl_croak(aTHX_ "usage: Win32::GetArchName()");
671 XSRETURN_PV(getenv("PROCESSOR_ARCHITECTURE"));
672 }
673
XS(w32_GetChipArch)674 XS(w32_GetChipArch)
675 {
676 dXSARGS;
677 SYSTEM_INFO sysinfo;
678 HMODULE module;
679 PFNGetNativeSystemInfo pfnGetNativeSystemInfo;
680 if (items)
681 Perl_croak(aTHX_ "usage: Win32::GetChipArch()");
682
683 Zero(&sysinfo,1,SYSTEM_INFO);
684 module = GetModuleHandle("kernel32.dll");
685 GETPROC(GetNativeSystemInfo);
686 if (pfnGetNativeSystemInfo)
687 pfnGetNativeSystemInfo(&sysinfo);
688 else
689 GetSystemInfo(&sysinfo);
690
691 XSRETURN_IV(sysinfo.wProcessorArchitecture);
692 }
693
XS(w32_GetChipName)694 XS(w32_GetChipName)
695 {
696 dXSARGS;
697 SYSTEM_INFO sysinfo;
698 HMODULE module;
699 PFNGetNativeSystemInfo pfnGetNativeSystemInfo;
700 if (items)
701 Perl_croak(aTHX_ "usage: Win32::GetChipName()");
702
703 Zero(&sysinfo,1,SYSTEM_INFO);
704 module = GetModuleHandle("kernel32.dll");
705 GETPROC(GetNativeSystemInfo);
706 if (pfnGetNativeSystemInfo)
707 pfnGetNativeSystemInfo(&sysinfo);
708 else
709 GetSystemInfo(&sysinfo);
710
711 /* XXX docs say dwProcessorType is deprecated on NT */
712 XSRETURN_IV(sysinfo.dwProcessorType);
713 }
714
XS(w32_GuidGen)715 XS(w32_GuidGen)
716 {
717 dXSARGS;
718 GUID guid;
719 char szGUID[50] = {'\0'};
720 HRESULT hr;
721 if (items)
722 Perl_croak(aTHX_ "usage: Win32::GuidGen()");
723
724 hr = CoCreateGuid(&guid);
725 if (SUCCEEDED(hr)) {
726 LPOLESTR pStr = NULL;
727 #ifdef __cplusplus
728 if (SUCCEEDED(StringFromCLSID(guid, &pStr))) {
729 #else
730 if (SUCCEEDED(StringFromCLSID(&guid, &pStr))) {
731 #endif
732 WideCharToMultiByte(CP_ACP, 0, pStr, (int)wcslen(pStr), szGUID,
733 sizeof(szGUID), NULL, NULL);
734 CoTaskMemFree(pStr);
735 XSRETURN_PV(szGUID);
736 }
737 }
738 XSRETURN_UNDEF;
739 }
740
741 XS(w32_GetFolderPath)
742 {
743 dXSARGS;
744 WCHAR wpath[MAX_PATH+1];
745 int folder;
746 int create = 0;
747
748 if (items != 1 && items != 2)
749 croak("usage: Win32::GetFolderPath($csidl [, $create])\n");
750
751 folder = (int)SvIV(ST(0));
752 if (items == 2)
753 create = SvTRUE(ST(1)) ? CSIDL_FLAG_CREATE : 0;
754
755 if (SUCCEEDED(SHGetFolderPathW(NULL, folder|create, NULL, 0, wpath))) {
756 ST(0) = wstr_to_ansipath(aTHX_ wpath);
757 XSRETURN(1);
758 }
759
760 if (SHGetSpecialFolderPathW(NULL, wpath, folder, !!create)) {
761 ST(0) = wstr_to_ansipath(aTHX_ wpath);
762 XSRETURN(1);
763 }
764
765 /* SHGetFolderPathW() and SHGetSpecialFolderPathW() may fail on older
766 * Perl versions that have replaced the Unicode environment with an
767 * ANSI version. Let's go spelunking in the registry now...
768 */
769 {
770 SV *sv;
771 HKEY hkey;
772 HKEY root = HKEY_CURRENT_USER;
773 const WCHAR *name = NULL;
774
775 switch (folder) {
776 case CSIDL_ADMINTOOLS: name = L"Administrative Tools"; break;
777 case CSIDL_APPDATA: name = L"AppData"; break;
778 case CSIDL_CDBURN_AREA: name = L"CD Burning"; break;
779 case CSIDL_COOKIES: name = L"Cookies"; break;
780 case CSIDL_DESKTOP:
781 case CSIDL_DESKTOPDIRECTORY: name = L"Desktop"; break;
782 case CSIDL_FAVORITES: name = L"Favorites"; break;
783 case CSIDL_FONTS: name = L"Fonts"; break;
784 case CSIDL_HISTORY: name = L"History"; break;
785 case CSIDL_INTERNET_CACHE: name = L"Cache"; break;
786 case CSIDL_LOCAL_APPDATA: name = L"Local AppData"; break;
787 case CSIDL_MYMUSIC: name = L"My Music"; break;
788 case CSIDL_MYPICTURES: name = L"My Pictures"; break;
789 case CSIDL_MYVIDEO: name = L"My Video"; break;
790 case CSIDL_NETHOOD: name = L"NetHood"; break;
791 case CSIDL_PERSONAL: name = L"Personal"; break;
792 case CSIDL_PRINTHOOD: name = L"PrintHood"; break;
793 case CSIDL_PROGRAMS: name = L"Programs"; break;
794 case CSIDL_RECENT: name = L"Recent"; break;
795 case CSIDL_SENDTO: name = L"SendTo"; break;
796 case CSIDL_STARTMENU: name = L"Start Menu"; break;
797 case CSIDL_STARTUP: name = L"Startup"; break;
798 case CSIDL_TEMPLATES: name = L"Templates"; break;
799 /* XXX L"Local Settings" */
800 }
801
802 if (!name) {
803 root = HKEY_LOCAL_MACHINE;
804 switch (folder) {
805 case CSIDL_COMMON_ADMINTOOLS: name = L"Common Administrative Tools"; break;
806 case CSIDL_COMMON_APPDATA: name = L"Common AppData"; break;
807 case CSIDL_COMMON_DESKTOPDIRECTORY: name = L"Common Desktop"; break;
808 case CSIDL_COMMON_DOCUMENTS: name = L"Common Documents"; break;
809 case CSIDL_COMMON_FAVORITES: name = L"Common Favorites"; break;
810 case CSIDL_COMMON_PROGRAMS: name = L"Common Programs"; break;
811 case CSIDL_COMMON_STARTMENU: name = L"Common Start Menu"; break;
812 case CSIDL_COMMON_STARTUP: name = L"Common Startup"; break;
813 case CSIDL_COMMON_TEMPLATES: name = L"Common Templates"; break;
814 case CSIDL_COMMON_MUSIC: name = L"CommonMusic"; break;
815 case CSIDL_COMMON_PICTURES: name = L"CommonPictures"; break;
816 case CSIDL_COMMON_VIDEO: name = L"CommonVideo"; break;
817 }
818 }
819 /* XXX todo
820 * case CSIDL_SYSTEM # GetSystemDirectory()
821 * case CSIDL_RESOURCES # %windir%\Resources\, For theme and other windows resources.
822 * case CSIDL_RESOURCES_LOCALIZED # %windir%\Resources\<LangID>, for theme and other windows specific resources.
823 */
824
825 #define SHELL_FOLDERS "Software\\Microsoft\\Windows\\CurrentVersion\\Explorer\\Shell Folders"
826
827 if (name && RegOpenKeyEx(root, SHELL_FOLDERS, 0, KEY_QUERY_VALUE, &hkey) == ERROR_SUCCESS) {
828 WCHAR data[MAX_PATH+1];
829 DWORD cb = sizeof(data)-sizeof(WCHAR);
830 DWORD type = REG_NONE;
831 long rc = RegQueryValueExW(hkey, name, NULL, &type, (BYTE*)&data, &cb);
832 RegCloseKey(hkey);
833 if (rc == ERROR_SUCCESS && type == REG_SZ && cb > sizeof(WCHAR) && data[0]) {
834 /* Make sure the string is properly terminated */
835 data[cb/sizeof(WCHAR)] = '\0';
836 ST(0) = wstr_to_ansipath(aTHX_ data);
837 XSRETURN(1);
838 }
839 }
840
841 #undef SHELL_FOLDERS
842
843 /* Unders some circumstances the registry entries seem to have a null string
844 * as their value even when the directory already exists. The environment
845 * variables do get set though, so try re-create a Unicode environment and
846 * check if they are there.
847 */
848 sv = NULL;
849 switch (folder) {
850 case CSIDL_APPDATA: sv = get_unicode_env(aTHX_ L"APPDATA"); break;
851 case CSIDL_PROFILE: sv = get_unicode_env(aTHX_ L"USERPROFILE"); break;
852 case CSIDL_PROGRAM_FILES: sv = get_unicode_env(aTHX_ L"ProgramFiles"); break;
853 case CSIDL_PROGRAM_FILES_COMMON: sv = get_unicode_env(aTHX_ L"CommonProgramFiles"); break;
854 case CSIDL_WINDOWS: sv = get_unicode_env(aTHX_ L"SystemRoot"); break;
855 }
856 if (sv) {
857 ST(0) = sv;
858 XSRETURN(1);
859 }
860 }
861
862 XSRETURN_UNDEF;
863 }
864
865 XS(w32_GetFileVersion)
866 {
867 dXSARGS;
868 DWORD size;
869 DWORD handle;
870 char *filename;
871 char *data;
872
873 if (items != 1)
874 croak("usage: Win32::GetFileVersion($filename)");
875
876 filename = SvPV_nolen(ST(0));
877 size = GetFileVersionInfoSize(filename, &handle);
878 if (!size)
879 XSRETURN_UNDEF;
880
881 New(0, data, size, char);
882 if (!data)
883 XSRETURN_UNDEF;
884
885 if (GetFileVersionInfo(filename, handle, size, data)) {
886 VS_FIXEDFILEINFO *info;
887 UINT len;
888 if (VerQueryValue(data, "\\", (void**)&info, &len)) {
889 int dwValueMS1 = (info->dwFileVersionMS>>16);
890 int dwValueMS2 = (info->dwFileVersionMS&0xffff);
891 int dwValueLS1 = (info->dwFileVersionLS>>16);
892 int dwValueLS2 = (info->dwFileVersionLS&0xffff);
893
894 if (GIMME_V == G_ARRAY) {
895 EXTEND(SP, 4);
896 XST_mIV(0, dwValueMS1);
897 XST_mIV(1, dwValueMS2);
898 XST_mIV(2, dwValueLS1);
899 XST_mIV(3, dwValueLS2);
900 items = 4;
901 }
902 else {
903 char version[50];
904 sprintf(version, "%d.%d.%d.%d", dwValueMS1, dwValueMS2, dwValueLS1, dwValueLS2);
905 XST_mPV(0, version);
906 }
907 }
908 }
909 else
910 items = 0;
911
912 Safefree(data);
913 XSRETURN(items);
914 }
915
916 #ifdef __CYGWIN__
917 XS(w32_SetChildShowWindow)
918 {
919 /* This function doesn't do anything useful for cygwin. In the
920 * MSWin32 case it modifies w32_showwindow, which is used by
921 * win32_spawnvp(). Since w32_showwindow is an internal variable
922 * inside the thread_intern structure, the MSWin32 implementation
923 * lives in win32/win32.c in the core Perl distribution.
924 */
925 dSP;
926 I32 ax = POPMARK;
927 EXTEND(SP,1);
928 XSRETURN_UNDEF;
929 }
930 #endif
931
932 XS(w32_GetCwd)
933 {
934 dXSARGS;
935 char* ptr;
936 if (items)
937 Perl_croak(aTHX_ "usage: Win32::GetCwd()");
938
939 /* Make the host for current directory */
940 ptr = PerlEnv_get_childdir();
941 /*
942 * If ptr != Nullch
943 * then it worked, set PV valid,
944 * else return 'undef'
945 */
946 if (ptr) {
947 SV *sv = sv_newmortal();
948 sv_setpv(sv, ptr);
949 PerlEnv_free_childdir(ptr);
950
951 #ifndef INCOMPLETE_TAINTS
952 SvTAINTED_on(sv);
953 #endif
954
955 EXTEND(SP,1);
956 ST(0) = sv;
957 XSRETURN(1);
958 }
959 XSRETURN_UNDEF;
960 }
961
962 XS(w32_SetCwd)
963 {
964 dXSARGS;
965 if (items != 1)
966 Perl_croak(aTHX_ "usage: Win32::SetCwd($cwd)");
967
968 if (SvUTF8(ST(0))) {
969 WCHAR *wide = sv_to_wstr(aTHX_ ST(0));
970 char *ansi = my_ansipath(wide);
971 int rc = PerlDir_chdir(ansi);
972 Safefree(wide);
973 Safefree(ansi);
974 if (!rc)
975 XSRETURN_YES;
976 }
977 else {
978 if (!PerlDir_chdir(SvPV_nolen(ST(0))))
979 XSRETURN_YES;
980 }
981
982 XSRETURN_NO;
983 }
984
985 XS(w32_GetNextAvailDrive)
986 {
987 dXSARGS;
988 char ix = 'C';
989 char root[] = "_:\\";
990
991 if (items)
992 Perl_croak(aTHX_ "usage: Win32::GetNextAvailDrive()");
993 EXTEND(SP,1);
994 while (ix <= 'Z') {
995 root[0] = ix++;
996 if (GetDriveType(root) == 1) {
997 root[2] = '\0';
998 XSRETURN_PV(root);
999 }
1000 }
1001 XSRETURN_UNDEF;
1002 }
1003
1004 XS(w32_GetLastError)
1005 {
1006 dXSARGS;
1007 if (items)
1008 Perl_croak(aTHX_ "usage: Win32::GetLastError()");
1009 EXTEND(SP,1);
1010 XSRETURN_IV(GetLastError());
1011 }
1012
1013 XS(w32_SetLastError)
1014 {
1015 dXSARGS;
1016 if (items != 1)
1017 Perl_croak(aTHX_ "usage: Win32::SetLastError($error)");
1018 SetLastError((DWORD)SvIV(ST(0)));
1019 XSRETURN_EMPTY;
1020 }
1021
1022 XS(w32_LoginName)
1023 {
1024 dXSARGS;
1025 WCHAR name[128];
1026 DWORD size = countof(name);
1027
1028 if (items)
1029 Perl_croak(aTHX_ "usage: Win32::LoginName()");
1030
1031 EXTEND(SP,1);
1032
1033 if (GetUserNameW(name, &size)) {
1034 ST(0) = wstr_to_sv(aTHX_ name);
1035 XSRETURN(1);
1036 }
1037
1038 XSRETURN_UNDEF;
1039 }
1040
1041 XS(w32_NodeName)
1042 {
1043 dXSARGS;
1044 char name[MAX_COMPUTERNAME_LENGTH+1];
1045 DWORD size = sizeof(name);
1046 if (items)
1047 Perl_croak(aTHX_ "usage: Win32::NodeName()");
1048 EXTEND(SP,1);
1049 if (GetComputerName(name,&size)) {
1050 /* size does NOT include NULL :-( */
1051 ST(0) = sv_2mortal(newSVpvn(name,size));
1052 XSRETURN(1);
1053 }
1054 XSRETURN_UNDEF;
1055 }
1056
1057
1058 XS(w32_DomainName)
1059 {
1060 dXSARGS;
1061 char dname[256];
1062 DWORD dnamelen = sizeof(dname);
1063 WKSTA_INFO_100 *pwi;
1064 DWORD retval;
1065
1066 if (items)
1067 Perl_croak(aTHX_ "usage: Win32::DomainName()");
1068
1069 EXTEND(SP,1);
1070
1071 retval = NetWkstaGetInfo(NULL, 100, (LPBYTE*)&pwi);
1072 /* NERR_Success *is* 0*/
1073 if (retval == 0) {
1074 if (pwi->wki100_langroup && *(pwi->wki100_langroup)) {
1075 WideCharToMultiByte(CP_ACP, 0, pwi->wki100_langroup,
1076 -1, (LPSTR)dname, dnamelen, NULL, NULL);
1077 }
1078 else {
1079 WideCharToMultiByte(CP_ACP, 0, pwi->wki100_computername,
1080 -1, (LPSTR)dname, dnamelen, NULL, NULL);
1081 }
1082 NetApiBufferFree(pwi);
1083 XSRETURN_PV(dname);
1084 }
1085 SetLastError(retval);
1086 XSRETURN_UNDEF;
1087 }
1088
1089 XS(w32_FsType)
1090 {
1091 dXSARGS;
1092 char fsname[256];
1093 DWORD flags, filecomplen;
1094 if (items)
1095 Perl_croak(aTHX_ "usage: Win32::FsType()");
1096 if (GetVolumeInformation(NULL, NULL, 0, NULL, &filecomplen,
1097 &flags, fsname, sizeof(fsname))) {
1098 if (GIMME_V == G_ARRAY) {
1099 XPUSHs(sv_2mortal(newSVpvn(fsname,strlen(fsname))));
1100 XPUSHs(sv_2mortal(newSViv(flags)));
1101 XPUSHs(sv_2mortal(newSViv(filecomplen)));
1102 PUTBACK;
1103 return;
1104 }
1105 EXTEND(SP,1);
1106 XSRETURN_PV(fsname);
1107 }
1108 XSRETURN_EMPTY;
1109 }
1110
1111 XS(w32_GetOSVersion)
1112 {
1113 dXSARGS;
1114 if (items)
1115 Perl_croak(aTHX_ "usage: Win32::GetOSVersion()");
1116
1117 if (GIMME_V == G_SCALAR) {
1118 XSRETURN_IV(g_osver.dwPlatformId);
1119 }
1120 XPUSHs(sv_2mortal(newSVpvn(g_osver.szCSDVersion, strlen(g_osver.szCSDVersion))));
1121
1122 XPUSHs(sv_2mortal(newSViv(g_osver.dwMajorVersion)));
1123 XPUSHs(sv_2mortal(newSViv(g_osver.dwMinorVersion)));
1124 XPUSHs(sv_2mortal(newSViv(g_osver.dwBuildNumber)));
1125 XPUSHs(sv_2mortal(newSViv(g_osver.dwPlatformId)));
1126 if (g_osver_ex) {
1127 XPUSHs(sv_2mortal(newSViv(g_osver.wServicePackMajor)));
1128 XPUSHs(sv_2mortal(newSViv(g_osver.wServicePackMinor)));
1129 XPUSHs(sv_2mortal(newSViv(g_osver.wSuiteMask)));
1130 XPUSHs(sv_2mortal(newSViv(g_osver.wProductType)));
1131 }
1132 PUTBACK;
1133 }
1134
1135 XS(w32_IsWinNT)
1136 {
1137 dXSARGS;
1138 if (items)
1139 Perl_croak(aTHX_ "usage: Win32::IsWinNT()");
1140 EXTEND(SP,1);
1141 XSRETURN_IV(g_osver.dwPlatformId == VER_PLATFORM_WIN32_NT);
1142 }
1143
1144 XS(w32_IsWin95)
1145 {
1146 dXSARGS;
1147 if (items)
1148 Perl_croak(aTHX_ "usage: Win32::IsWin95()");
1149 EXTEND(SP,1);
1150 XSRETURN_IV(g_osver.dwPlatformId == VER_PLATFORM_WIN32_WINDOWS);
1151 }
1152
1153 XS(w32_FormatMessage)
1154 {
1155 dXSARGS;
1156 DWORD source = 0;
1157 char msgbuf[ONE_K_BUFSIZE];
1158
1159 if (items != 1)
1160 Perl_croak(aTHX_ "usage: Win32::FormatMessage($errno)");
1161
1162 if (FormatMessageA(FORMAT_MESSAGE_FROM_SYSTEM,
1163 &source, (DWORD)SvIV(ST(0)), 0,
1164 msgbuf, sizeof(msgbuf)-1, NULL))
1165 {
1166 XSRETURN_PV(msgbuf);
1167 }
1168
1169 XSRETURN_UNDEF;
1170 }
1171
1172 XS(w32_Spawn)
1173 {
1174 dXSARGS;
1175 char *cmd, *args;
1176 void *env;
1177 char *dir;
1178 PROCESS_INFORMATION stProcInfo;
1179 STARTUPINFO stStartInfo;
1180 BOOL bSuccess = FALSE;
1181
1182 if (items != 3)
1183 Perl_croak(aTHX_ "usage: Win32::Spawn($cmdName, $args, $PID)");
1184
1185 cmd = SvPV_nolen(ST(0));
1186 args = SvPV_nolen(ST(1));
1187
1188 env = PerlEnv_get_childenv();
1189 dir = PerlEnv_get_childdir();
1190
1191 memset(&stStartInfo, 0, sizeof(stStartInfo)); /* Clear the block */
1192 stStartInfo.cb = sizeof(stStartInfo); /* Set the structure size */
1193 stStartInfo.dwFlags = STARTF_USESHOWWINDOW; /* Enable wShowWindow control */
1194 stStartInfo.wShowWindow = SW_SHOWMINNOACTIVE; /* Start min (normal) */
1195
1196 if (CreateProcess(
1197 cmd, /* Image path */
1198 args, /* Arguments for command line */
1199 NULL, /* Default process security */
1200 NULL, /* Default thread security */
1201 FALSE, /* Must be TRUE to use std handles */
1202 NORMAL_PRIORITY_CLASS, /* No special scheduling */
1203 env, /* Inherit our environment block */
1204 dir, /* Inherit our currrent directory */
1205 &stStartInfo, /* -> Startup info */
1206 &stProcInfo)) /* <- Process info (if OK) */
1207 {
1208 int pid = (int)stProcInfo.dwProcessId;
1209 sv_setiv(ST(2), pid);
1210 CloseHandle(stProcInfo.hThread);/* library source code does this. */
1211 bSuccess = TRUE;
1212 }
1213 PerlEnv_free_childenv(env);
1214 PerlEnv_free_childdir(dir);
1215 XSRETURN_IV(bSuccess);
1216 }
1217
1218 XS(w32_GetTickCount)
1219 {
1220 dXSARGS;
1221 DWORD msec = GetTickCount();
1222 if (items)
1223 Perl_croak(aTHX_ "usage: Win32::GetTickCount()");
1224 EXTEND(SP,1);
1225 if ((IV)msec > 0)
1226 XSRETURN_IV(msec);
1227 XSRETURN_NV(msec);
1228 }
1229
1230 XS(w32_GetShortPathName)
1231 {
1232 dXSARGS;
1233 DWORD len;
1234 WCHAR wshort[MAX_PATH+1], *wlong;
1235
1236 if (items != 1)
1237 Perl_croak(aTHX_ "usage: Win32::GetShortPathName($longPathName)");
1238
1239 wlong = sv_to_wstr(aTHX_ ST(0));
1240 len = GetShortPathNameW(wlong, wshort, countof(wshort));
1241 Safefree(wlong);
1242
1243 if (len && len < sizeof(wshort)) {
1244 ST(0) = wstr_to_sv(aTHX_ wshort);
1245 XSRETURN(1);
1246 }
1247
1248 XSRETURN_UNDEF;
1249 }
1250
1251 XS(w32_GetFullPathName)
1252 {
1253 dXSARGS;
1254 char *fullname;
1255 char *ansi = NULL;
1256
1257 /* The code below relies on the fact that PerlDir_mapX() returns an
1258 * absolute path, which is only true under PERL_IMPLICIT_SYS when
1259 * we use the virtualization code from win32/vdir.h.
1260 * Without it PerlDir_mapX() is a no-op and we need to use the same
1261 * code as we use for Cygwin.
1262 */
1263 #if __CYGWIN__ || !defined(PERL_IMPLICIT_SYS)
1264 char buffer[2*MAX_PATH];
1265 #endif
1266
1267 if (items != 1)
1268 Perl_croak(aTHX_ "usage: Win32::GetFullPathName($filename)");
1269
1270 #if __CYGWIN__ || !defined(PERL_IMPLICIT_SYS)
1271 {
1272 WCHAR *filename = sv_to_wstr(aTHX_ ST(0));
1273 WCHAR full[2*MAX_PATH];
1274 DWORD len = GetFullPathNameW(filename, countof(full), full, NULL);
1275 Safefree(filename);
1276 if (len == 0 || len >= countof(full))
1277 XSRETURN_EMPTY;
1278 ansi = fullname = my_ansipath(full);
1279 }
1280 #else
1281 /* Don't use my_ansipath() unless the $filename argument is in Unicode.
1282 * If the relative path doesn't exist, GetShortPathName() will fail and
1283 * my_ansipath() will use the long name with replacement characters.
1284 * In that case we will be better off using PerlDir_mapA(), which
1285 * already uses the ANSI name of the current directory.
1286 *
1287 * XXX The one missing case is where we could downgrade $filename
1288 * XXX from UTF8 into the current codepage.
1289 */
1290 if (SvUTF8(ST(0))) {
1291 WCHAR *filename = sv_to_wstr(aTHX_ ST(0));
1292 WCHAR *mappedname = PerlDir_mapW(filename);
1293 Safefree(filename);
1294 ansi = fullname = my_ansipath(mappedname);
1295 }
1296 else {
1297 fullname = PerlDir_mapA(SvPV_nolen(ST(0)));
1298 }
1299 # if PERL_VERSION < 8
1300 {
1301 /* PerlDir_mapX() in Perl 5.6 used to return forward slashes */
1302 char *str = fullname;
1303 while (*str) {
1304 if (*str == '/')
1305 *str = '\\';
1306 ++str;
1307 }
1308 }
1309 # endif
1310 #endif
1311
1312 /* GetFullPathName() on Windows NT drops trailing backslash */
1313 if (g_osver.dwMajorVersion == 4 && *fullname) {
1314 STRLEN len;
1315 char *pv = SvPV(ST(0), len);
1316 char *lastchar = fullname + strlen(fullname) - 1;
1317 /* If ST(0) ends with a slash, but fullname doesn't ... */
1318 if (len && (pv[len-1] == '/' || pv[len-1] == '\\') && *lastchar != '\\') {
1319 /* fullname is the MAX_PATH+1 sized buffer returned from PerlDir_mapA()
1320 * or the 2*MAX_PATH sized local buffer in the __CYGWIN__ case.
1321 */
1322 if (lastchar - fullname < MAX_PATH - 1)
1323 strcpy(lastchar+1, "\\");
1324 }
1325 }
1326
1327 if (GIMME_V == G_ARRAY) {
1328 char *filepart = strrchr(fullname, '\\');
1329
1330 EXTEND(SP,1);
1331 if (filepart) {
1332 XST_mPV(1, ++filepart);
1333 *filepart = '\0';
1334 }
1335 else {
1336 XST_mPVN(1, "", 0);
1337 }
1338 items = 2;
1339 }
1340 XST_mPV(0, fullname);
1341
1342 if (ansi)
1343 Safefree(ansi);
1344 XSRETURN(items);
1345 }
1346
1347 XS(w32_GetLongPathName)
1348 {
1349 dXSARGS;
1350 WCHAR *wstr, *long_path, wide_path[MAX_PATH+1];
1351
1352 if (items != 1)
1353 Perl_croak(aTHX_ "usage: Win32::GetLongPathName($pathname)");
1354
1355 wstr = sv_to_wstr(aTHX_ ST(0));
1356
1357 if (wcslen(wstr) < (size_t)countof(wide_path)) {
1358 wcscpy(wide_path, wstr);
1359 long_path = my_longpathW(wide_path);
1360 if (long_path) {
1361 Safefree(wstr);
1362 ST(0) = wstr_to_sv(aTHX_ long_path);
1363 XSRETURN(1);
1364 }
1365 }
1366 Safefree(wstr);
1367 XSRETURN_EMPTY;
1368 }
1369
1370 XS(w32_GetANSIPathName)
1371 {
1372 dXSARGS;
1373 WCHAR *wide_path;
1374
1375 if (items != 1)
1376 Perl_croak(aTHX_ "usage: Win32::GetANSIPathName($pathname)");
1377
1378 wide_path = sv_to_wstr(aTHX_ ST(0));
1379 ST(0) = wstr_to_ansipath(aTHX_ wide_path);
1380 Safefree(wide_path);
1381 XSRETURN(1);
1382 }
1383
1384 XS(w32_Sleep)
1385 {
1386 dXSARGS;
1387 if (items != 1)
1388 Perl_croak(aTHX_ "usage: Win32::Sleep($milliseconds)");
1389 Sleep((DWORD)SvIV(ST(0)));
1390 XSRETURN_YES;
1391 }
1392
1393 XS(w32_CopyFile)
1394 {
1395 dXSARGS;
1396 BOOL bResult;
1397 char *pszSourceFile;
1398 char szSourceFile[MAX_PATH+1];
1399
1400 if (items != 3)
1401 Perl_croak(aTHX_ "usage: Win32::CopyFile($from, $to, $overwrite)");
1402
1403 pszSourceFile = PerlDir_mapA(SvPV_nolen(ST(0)));
1404 if (strlen(pszSourceFile) < sizeof(szSourceFile)) {
1405 strcpy(szSourceFile, pszSourceFile);
1406 bResult = CopyFileA(szSourceFile, PerlDir_mapA(SvPV_nolen(ST(1))), !SvTRUE(ST(2)));
1407 if (bResult)
1408 XSRETURN_YES;
1409 }
1410 XSRETURN_NO;
1411 }
1412
1413 XS(w32_OutputDebugString)
1414 {
1415 dXSARGS;
1416 if (items != 1)
1417 Perl_croak(aTHX_ "usage: Win32::OutputDebugString($string)");
1418
1419 if (SvUTF8(ST(0))) {
1420 WCHAR *str = sv_to_wstr(aTHX_ ST(0));
1421 OutputDebugStringW(str);
1422 Safefree(str);
1423 }
1424 else
1425 OutputDebugStringA(SvPV_nolen(ST(0)));
1426
1427 XSRETURN_EMPTY;
1428 }
1429
1430 XS(w32_GetCurrentProcessId)
1431 {
1432 dXSARGS;
1433 if (items)
1434 Perl_croak(aTHX_ "usage: Win32::GetCurrentProcessId()");
1435 EXTEND(SP,1);
1436 XSRETURN_IV(GetCurrentProcessId());
1437 }
1438
1439 XS(w32_GetCurrentThreadId)
1440 {
1441 dXSARGS;
1442 if (items)
1443 Perl_croak(aTHX_ "usage: Win32::GetCurrentThreadId()");
1444 EXTEND(SP,1);
1445 XSRETURN_IV(GetCurrentThreadId());
1446 }
1447
1448 XS(w32_CreateDirectory)
1449 {
1450 dXSARGS;
1451 BOOL result;
1452
1453 if (items != 1)
1454 Perl_croak(aTHX_ "usage: Win32::CreateDirectory($dir)");
1455
1456 if (SvUTF8(ST(0))) {
1457 WCHAR *dir = sv_to_wstr(aTHX_ ST(0));
1458 result = CreateDirectoryW(dir, NULL);
1459 Safefree(dir);
1460 }
1461 else {
1462 result = CreateDirectoryA(SvPV_nolen(ST(0)), NULL);
1463 }
1464
1465 ST(0) = boolSV(result);
1466 XSRETURN(1);
1467 }
1468
1469 XS(w32_CreateFile)
1470 {
1471 dXSARGS;
1472 HANDLE handle;
1473
1474 if (items != 1)
1475 Perl_croak(aTHX_ "usage: Win32::CreateFile($file)");
1476
1477 if (SvUTF8(ST(0))) {
1478 WCHAR *file = sv_to_wstr(aTHX_ ST(0));
1479 handle = CreateFileW(file, GENERIC_WRITE, FILE_SHARE_WRITE,
1480 NULL, CREATE_NEW, FILE_ATTRIBUTE_NORMAL, NULL);
1481 Safefree(file);
1482 }
1483 else {
1484 handle = CreateFileA(SvPV_nolen(ST(0)), GENERIC_WRITE, FILE_SHARE_WRITE,
1485 NULL, CREATE_NEW, FILE_ATTRIBUTE_NORMAL, NULL);
1486 }
1487
1488 if (handle != INVALID_HANDLE_VALUE)
1489 CloseHandle(handle);
1490
1491 ST(0) = boolSV(handle != INVALID_HANDLE_VALUE);
1492 XSRETURN(1);
1493 }
1494
1495 XS(w32_GetSystemMetrics)
1496 {
1497 dXSARGS;
1498
1499 if (items != 1)
1500 Perl_croak(aTHX_ "usage: Win32::GetSystemMetrics($index)");
1501
1502 XSRETURN_IV(GetSystemMetrics((int)SvIV(ST(0))));
1503 }
1504
1505 XS(w32_GetProductInfo)
1506 {
1507 dXSARGS;
1508 DWORD type;
1509 HMODULE module;
1510 PFNGetProductInfo pfnGetProductInfo;
1511
1512 if (items != 4)
1513 Perl_croak(aTHX_ "usage: Win32::GetProductInfo($major,$minor,$spmajor,$spminor)");
1514
1515 module = GetModuleHandle("kernel32.dll");
1516 GETPROC(GetProductInfo);
1517 if (pfnGetProductInfo &&
1518 pfnGetProductInfo((DWORD)SvIV(ST(0)), (DWORD)SvIV(ST(1)),
1519 (DWORD)SvIV(ST(2)), (DWORD)SvIV(ST(3)), &type))
1520 {
1521 XSRETURN_IV(type);
1522 }
1523
1524 /* PRODUCT_UNDEFINED */
1525 XSRETURN_IV(0);
1526 }
1527
1528 XS(w32_GetACP)
1529 {
1530 dXSARGS;
1531 if (items)
1532 Perl_croak(aTHX_ "usage: Win32::GetACP()");
1533 EXTEND(SP,1);
1534 XSRETURN_IV(GetACP());
1535 }
1536
1537 XS(w32_GetConsoleCP)
1538 {
1539 dXSARGS;
1540 if (items)
1541 Perl_croak(aTHX_ "usage: Win32::GetConsoleCP()");
1542 EXTEND(SP,1);
1543 XSRETURN_IV(GetConsoleCP());
1544 }
1545
1546 XS(w32_GetConsoleOutputCP)
1547 {
1548 dXSARGS;
1549 if (items)
1550 Perl_croak(aTHX_ "usage: Win32::GetConsoleOutputCP()");
1551 EXTEND(SP,1);
1552 XSRETURN_IV(GetConsoleOutputCP());
1553 }
1554
1555 XS(w32_GetOEMCP)
1556 {
1557 dXSARGS;
1558 if (items)
1559 Perl_croak(aTHX_ "usage: Win32::GetOEMCP()");
1560 EXTEND(SP,1);
1561 XSRETURN_IV(GetOEMCP());
1562 }
1563
1564 XS(w32_SetConsoleCP)
1565 {
1566 dXSARGS;
1567
1568 if (items != 1)
1569 Perl_croak(aTHX_ "usage: Win32::SetConsoleCP($id)");
1570
1571 XSRETURN_IV(SetConsoleCP((int)SvIV(ST(0))));
1572 }
1573
1574 XS(w32_SetConsoleOutputCP)
1575 {
1576 dXSARGS;
1577
1578 if (items != 1)
1579 Perl_croak(aTHX_ "usage: Win32::SetConsoleOutputCP($id)");
1580
1581 XSRETURN_IV(SetConsoleOutputCP((int)SvIV(ST(0))));
1582 }
1583
1584 XS(w32_GetProcessPrivileges)
1585 {
1586 dXSARGS;
1587 BOOL ret;
1588 HV *priv_hv;
1589 HANDLE proc_handle, token;
1590 char *priv_name = NULL;
1591 TOKEN_PRIVILEGES *privs = NULL;
1592 DWORD i, pid, priv_name_len = 100, privs_len = 300;
1593
1594 if (items > 1)
1595 Perl_croak(aTHX_ "usage: Win32::GetProcessPrivileges([$pid])");
1596
1597 if (items == 0) {
1598 EXTEND(SP, 1);
1599 pid = GetCurrentProcessId();
1600 }
1601 else {
1602 pid = (DWORD)SvUV(ST(0));
1603 }
1604
1605 proc_handle = OpenProcess(PROCESS_QUERY_INFORMATION, FALSE, pid);
1606
1607 if (!proc_handle)
1608 XSRETURN_NO;
1609
1610 ret = OpenProcessToken(proc_handle, TOKEN_QUERY, &token);
1611 CloseHandle(proc_handle);
1612
1613 if (!ret)
1614 XSRETURN_NO;
1615
1616 do {
1617 Renewc(privs, privs_len, char, TOKEN_PRIVILEGES);
1618 ret = GetTokenInformation(
1619 token, TokenPrivileges, privs, privs_len, &privs_len
1620 );
1621 } while (!ret && GetLastError() == ERROR_INSUFFICIENT_BUFFER);
1622
1623 CloseHandle(token);
1624
1625 if (!ret) {
1626 Safefree(privs);
1627 XSRETURN_NO;
1628 }
1629
1630 priv_hv = newHV();
1631 New(0, priv_name, priv_name_len, char);
1632
1633 for (i = 0; i < privs->PrivilegeCount; ++i) {
1634 DWORD ret_len = 0;
1635 LUID_AND_ATTRIBUTES *priv = &privs->Privileges[i];
1636 BOOL is_enabled = !!(priv->Attributes & SE_PRIVILEGE_ENABLED);
1637
1638 if (priv->Attributes & SE_PRIVILEGE_REMOVED)
1639 continue;
1640
1641 do {
1642 ret_len = priv_name_len;
1643 ret = LookupPrivilegeNameA(
1644 NULL, &priv->Luid, priv_name, &ret_len
1645 );
1646
1647 if (ret_len > priv_name_len) {
1648 priv_name_len = ret_len + 1;
1649 Renew(priv_name, priv_name_len, char);
1650 }
1651 } while (!ret && GetLastError() == ERROR_INSUFFICIENT_BUFFER);
1652
1653 if (!ret) {
1654 SvREFCNT_dec((SV*)priv_hv);
1655 Safefree(privs);
1656 Safefree(priv_name);
1657 XSRETURN_NO;
1658 }
1659
1660 hv_store(priv_hv, priv_name, ret_len, newSViv(is_enabled), 0);
1661 }
1662
1663 Safefree(privs);
1664 Safefree(priv_name);
1665
1666 ST(0) = sv_2mortal(newRV_noinc((SV*)priv_hv));
1667 XSRETURN(1);
1668 }
1669
1670 XS(w32_IsDeveloperModeEnabled)
1671 {
1672 dXSARGS;
1673 LONG status;
1674 DWORD val, val_size = sizeof(val);
1675 PFNRegGetValueA pfnRegGetValueA;
1676 HMODULE module;
1677
1678 if (items)
1679 Perl_croak(aTHX_ "usage: Win32::IsDeveloperModeEnabled()");
1680
1681 EXTEND(SP, 1);
1682
1683 /* developer mode was introduced in Windows 10 */
1684 if (g_osver.dwMajorVersion < 10)
1685 XSRETURN_NO;
1686
1687 module = GetModuleHandleA("advapi32.dll");
1688 GETPROC(RegGetValueA);
1689 if (!pfnRegGetValueA)
1690 XSRETURN_NO;
1691
1692 status = pfnRegGetValueA(
1693 HKEY_LOCAL_MACHINE,
1694 "SOFTWARE\\Microsoft\\Windows\\CurrentVersion\\AppModelUnlock",
1695 "AllowDevelopmentWithoutDevLicense",
1696 RRF_RT_REG_DWORD | KEY_WOW64_64KEY,
1697 NULL,
1698 &val,
1699 &val_size
1700 );
1701
1702 if (status == ERROR_SUCCESS && val == 1)
1703 XSRETURN_YES;
1704
1705 XSRETURN_NO;
1706 }
1707
1708 #ifdef WINHTTPAPI
1709
1710 XS(w32_HttpGetFile)
1711 {
1712 dXSARGS;
1713 WCHAR *url = NULL, *file = NULL, *hostName = NULL, *urlPath = NULL;
1714 bool bIgnoreCertErrors = FALSE;
1715 WCHAR msgbuf[ONE_K_BUFSIZE];
1716 BOOL bResults = FALSE;
1717 HINTERNET hSession = NULL,
1718 hConnect = NULL,
1719 hRequest = NULL;
1720 HANDLE hOut = INVALID_HANDLE_VALUE;
1721 BOOL bParsed = FALSE,
1722 bAborted = FALSE,
1723 bFileError = FALSE,
1724 bHttpError = FALSE;
1725 DWORD error = 0;
1726 URL_COMPONENTS urlComp;
1727 LPCWSTR acceptTypes[] = { L"*/*", NULL };
1728 DWORD dwHttpStatusCode = 0, dwQuerySize = 0;
1729
1730 if (items < 2 || items > 3)
1731 croak("usage: Win32::HttpGetFile($url, $file[, $ignore_cert_errors])");
1732
1733 url = sv_to_wstr(aTHX_ ST(0));
1734 file = sv_to_wstr(aTHX_ ST(1));
1735
1736 if (items == 3)
1737 bIgnoreCertErrors = (BOOL)SvIV(ST(2));
1738
1739 /* Initialize the URL_COMPONENTS structure, setting the required
1740 * component lengths to non-zero so that they get populated.
1741 */
1742 ZeroMemory(&urlComp, sizeof(urlComp));
1743 urlComp.dwStructSize = sizeof(urlComp);
1744 urlComp.dwSchemeLength = (DWORD)-1;
1745 urlComp.dwHostNameLength = (DWORD)-1;
1746 urlComp.dwUrlPathLength = (DWORD)-1;
1747 urlComp.dwExtraInfoLength = (DWORD)-1;
1748
1749 /* Parse the URL. */
1750 bParsed = WinHttpCrackUrl(url, (DWORD)wcslen(url), 0, &urlComp);
1751
1752 /* Only support http and htts, not ftp, gopher, etc. */
1753 if (bParsed
1754 && !(urlComp.nScheme == INTERNET_SCHEME_HTTPS
1755 || urlComp.nScheme == INTERNET_SCHEME_HTTP)) {
1756 SetLastError(12006); /* not a recognized protocol */
1757 bParsed = FALSE;
1758 }
1759
1760 if (bParsed) {
1761 New(0, hostName, urlComp.dwHostNameLength + 1, WCHAR);
1762 wcsncpy(hostName, urlComp.lpszHostName, urlComp.dwHostNameLength);
1763 hostName[urlComp.dwHostNameLength] = 0;
1764
1765 New(0, urlPath, urlComp.dwUrlPathLength + urlComp.dwExtraInfoLength + 1, WCHAR);
1766 wcsncpy(urlPath, urlComp.lpszUrlPath, urlComp.dwUrlPathLength + urlComp.dwExtraInfoLength);
1767 urlPath[urlComp.dwUrlPathLength + urlComp.dwExtraInfoLength] = 0;
1768
1769 /* Use WinHttpOpen to obtain a session handle. */
1770 hSession = WinHttpOpen(L"Perl",
1771 WINHTTP_ACCESS_TYPE_NO_PROXY,
1772 WINHTTP_NO_PROXY_NAME,
1773 WINHTTP_NO_PROXY_BYPASS,
1774 0);
1775 }
1776
1777 /* Specify an HTTP server. */
1778 if (hSession)
1779 hConnect = WinHttpConnect(hSession,
1780 hostName,
1781 urlComp.nPort,
1782 0);
1783
1784 /* Create an HTTP request handle. */
1785 if (hConnect)
1786 hRequest = WinHttpOpenRequest(hConnect,
1787 L"GET",
1788 urlPath,
1789 NULL,
1790 WINHTTP_NO_REFERER,
1791 acceptTypes,
1792 urlComp.nScheme == INTERNET_SCHEME_HTTPS
1793 ? WINHTTP_FLAG_SECURE
1794 : 0);
1795
1796 /* If specified, disable certificate-related errors for https connections. */
1797 if (hRequest
1798 && bIgnoreCertErrors
1799 && urlComp.nScheme == INTERNET_SCHEME_HTTPS) {
1800 DWORD secFlags = SECURITY_FLAG_IGNORE_CERT_CN_INVALID
1801 | SECURITY_FLAG_IGNORE_CERT_DATE_INVALID
1802 | SECURITY_FLAG_IGNORE_UNKNOWN_CA
1803 | SECURITY_FLAG_IGNORE_CERT_WRONG_USAGE;
1804 if(!WinHttpSetOption(hRequest,
1805 WINHTTP_OPTION_SECURITY_FLAGS,
1806 &secFlags,
1807 sizeof(secFlags))) {
1808 bAborted = TRUE;
1809 }
1810 }
1811
1812 /* Call WinHttpGetProxyForUrl with our target URL. If auto-proxy succeeds,
1813 * then set the proxy info on the request handle. If auto-proxy fails,
1814 * ignore the error and attempt to send the HTTP request directly to the
1815 * target server (using the default WINHTTP_ACCESS_TYPE_NO_PROXY
1816 * configuration, which the request handle will inherit from the session).
1817 */
1818 if (hRequest && !bAborted) {
1819 WINHTTP_AUTOPROXY_OPTIONS AutoProxyOptions;
1820 WINHTTP_PROXY_INFO ProxyInfo;
1821 DWORD cbProxyInfoSize = sizeof(ProxyInfo);
1822
1823 ZeroMemory(&AutoProxyOptions, sizeof(AutoProxyOptions));
1824 ZeroMemory(&ProxyInfo, sizeof(ProxyInfo));
1825 AutoProxyOptions.dwFlags = WINHTTP_AUTOPROXY_AUTO_DETECT;
1826 AutoProxyOptions.dwAutoDetectFlags =
1827 WINHTTP_AUTO_DETECT_TYPE_DHCP |
1828 WINHTTP_AUTO_DETECT_TYPE_DNS_A;
1829 AutoProxyOptions.fAutoLogonIfChallenged = TRUE;
1830
1831 if(WinHttpGetProxyForUrl(hSession,
1832 url,
1833 &AutoProxyOptions,
1834 &ProxyInfo)) {
1835 if(!WinHttpSetOption(hRequest,
1836 WINHTTP_OPTION_PROXY,
1837 &ProxyInfo,
1838 cbProxyInfoSize)) {
1839 bAborted = TRUE;
1840 Perl_warn(aTHX_ "Win32::HttpGetFile: setting proxy options failed");
1841 }
1842 Safefree(ProxyInfo.lpszProxy);
1843 Safefree(ProxyInfo.lpszProxyBypass);
1844 }
1845 }
1846
1847 /* Send a request. */
1848 if (hRequest && !bAborted)
1849 bResults = WinHttpSendRequest(hRequest,
1850 WINHTTP_NO_ADDITIONAL_HEADERS,
1851 0,
1852 WINHTTP_NO_REQUEST_DATA,
1853 0,
1854 0,
1855 0);
1856
1857 /* End the request. */
1858 if (bResults)
1859 bResults = WinHttpReceiveResponse(hRequest, NULL);
1860
1861 /* Retrieve HTTP status code. */
1862 if (bResults) {
1863 dwQuerySize = sizeof(dwHttpStatusCode);
1864 bResults = WinHttpQueryHeaders(hRequest,
1865 WINHTTP_QUERY_STATUS_CODE | WINHTTP_QUERY_FLAG_NUMBER,
1866 WINHTTP_HEADER_NAME_BY_INDEX,
1867 &dwHttpStatusCode,
1868 &dwQuerySize,
1869 WINHTTP_NO_HEADER_INDEX);
1870 }
1871
1872 /* Retrieve HTTP status text. Note this may be a success message. */
1873 if (bResults) {
1874 dwQuerySize = ONE_K_BUFSIZE * 2 - 2;
1875 ZeroMemory(&msgbuf, ONE_K_BUFSIZE * 2);
1876 bResults = WinHttpQueryHeaders(hRequest,
1877 WINHTTP_QUERY_STATUS_TEXT,
1878 WINHTTP_HEADER_NAME_BY_INDEX,
1879 msgbuf,
1880 &dwQuerySize,
1881 WINHTTP_NO_HEADER_INDEX);
1882 }
1883
1884 /* There is no point in successfully downloading an error page from
1885 * the server, so consider HTTP errors to be failures.
1886 */
1887 if (bResults) {
1888 if (dwHttpStatusCode < 200 || dwHttpStatusCode > 299) {
1889 bResults = FALSE;
1890 bHttpError = TRUE;
1891 }
1892 }
1893
1894 /* Create output file for download. */
1895 if (bResults) {
1896 hOut = CreateFileW(file,
1897 GENERIC_WRITE,
1898 FILE_SHARE_READ | FILE_SHARE_WRITE,
1899 NULL,
1900 CREATE_ALWAYS,
1901 FILE_ATTRIBUTE_NORMAL,
1902 NULL);
1903
1904 if (hOut == INVALID_HANDLE_VALUE)
1905 bFileError = TRUE;
1906 }
1907
1908 if (!bFileError && bResults) {
1909 DWORD dwDownloaded = 0;
1910 DWORD dwBytesWritten = 0;
1911 DWORD dwSize = 65536;
1912 char *pszOutBuffer;
1913
1914 New(0, pszOutBuffer, dwSize, char);
1915
1916 /* Keep checking for data until there is nothing left. */
1917 while (1) {
1918 if (!WinHttpReadData(hRequest,
1919 (LPVOID)pszOutBuffer,
1920 dwSize,
1921 &dwDownloaded)) {
1922 bAborted = TRUE;
1923 break;
1924 }
1925 if (!dwDownloaded)
1926 break;
1927
1928 /* Write what we just read to the output file */
1929 if (!WriteFile(hOut,
1930 pszOutBuffer,
1931 dwDownloaded,
1932 &dwBytesWritten,
1933 NULL)) {
1934 bAborted = TRUE;
1935 bFileError = TRUE;
1936 break;
1937 }
1938
1939 }
1940
1941 Safefree(pszOutBuffer);
1942 }
1943 else {
1944 bAborted = TRUE;
1945 }
1946
1947 /* Clean-up may lose this. */
1948 if (bAborted)
1949 error = GetLastError();
1950
1951 /* If we successfully opened the output file but failed later, mark
1952 * the file for deletion.
1953 */
1954 if (bAborted && hOut != INVALID_HANDLE_VALUE)
1955 (void) DeleteFileW(file);
1956
1957 /* Close any open handles. */
1958 if (hOut != INVALID_HANDLE_VALUE) CloseHandle(hOut);
1959 if (hRequest) WinHttpCloseHandle(hRequest);
1960 if (hConnect) WinHttpCloseHandle(hConnect);
1961 if (hSession) WinHttpCloseHandle(hSession);
1962
1963 Safefree(url);
1964 Safefree(file);
1965 Safefree(hostName);
1966 Safefree(urlPath);
1967
1968 /* Retrieve system and WinHttp error messages, or compose a user-defined
1969 * error code if we got a failed HTTP status text above. Conveniently, adding
1970 * 1e9 to the HTTP status sets bit 29, denoting a user-defined error code,
1971 * and also makes it easy to lop off the upper part and just get HTTP status.
1972 */
1973 if (bAborted) {
1974 if (bHttpError) {
1975 SetLastError(dwHttpStatusCode + 1000000000);
1976 }
1977 else {
1978 DWORD msgFlags = bFileError
1979 ? FORMAT_MESSAGE_FROM_SYSTEM
1980 : FORMAT_MESSAGE_FROM_HMODULE;
1981 msgFlags |= FORMAT_MESSAGE_IGNORE_INSERTS;
1982
1983 ZeroMemory(&msgbuf, ONE_K_BUFSIZE * 2);
1984 if (!FormatMessageW(msgFlags,
1985 GetModuleHandleW(L"winhttp.dll"),
1986 error,
1987 0,
1988 msgbuf,
1989 ONE_K_BUFSIZE - 1, /* TCHARs, not bytes */
1990 NULL)) {
1991 wcsncpy(msgbuf, L"unable to format error message", ONE_K_BUFSIZE - 1);
1992 }
1993 SetLastError(error);
1994 }
1995 }
1996
1997 if (GIMME_V == G_SCALAR) {
1998 EXTEND(SP, 1);
1999 ST(0) = !bAborted ? &PL_sv_yes : &PL_sv_no;
2000 XSRETURN(1);
2001 }
2002 else if (GIMME_V == G_ARRAY) {
2003 EXTEND(SP, 2);
2004 ST(0) = !bAborted ? &PL_sv_yes : &PL_sv_no;
2005 ST(1) = wstr_to_sv(aTHX_ msgbuf);
2006 XSRETURN(2);
2007 }
2008 else {
2009 XSRETURN_EMPTY;
2010 }
2011 }
2012
2013 #endif
2014
2015 MODULE = Win32 PACKAGE = Win32
2016
2017 PROTOTYPES: DISABLE
2018
2019 BOOT:
2020 {
2021 const char *file = __FILE__;
2022
2023 if (g_osver.dwOSVersionInfoSize == 0) {
2024 g_osver.dwOSVersionInfoSize = sizeof(g_osver);
2025 if (!GetVersionExA((OSVERSIONINFOA*)&g_osver)) {
2026 g_osver_ex = FALSE;
2027 g_osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFOA);
2028 GetVersionExA((OSVERSIONINFOA*)&g_osver);
2029 }
2030 }
2031
2032 newXS("Win32::LookupAccountName", w32_LookupAccountName, file);
2033 newXS("Win32::LookupAccountSID", w32_LookupAccountSID, file);
2034 newXS("Win32::InitiateSystemShutdown", w32_InitiateSystemShutdown, file);
2035 newXS("Win32::AbortSystemShutdown", w32_AbortSystemShutdown, file);
2036 newXS("Win32::ExpandEnvironmentStrings", w32_ExpandEnvironmentStrings, file);
2037 newXS("Win32::MsgBox", w32_MsgBox, file);
2038 newXS("Win32::LoadLibrary", w32_LoadLibrary, file);
2039 newXS("Win32::FreeLibrary", w32_FreeLibrary, file);
2040 newXS("Win32::GetProcAddress", w32_GetProcAddress, file);
2041 newXS("Win32::RegisterServer", w32_RegisterServer, file);
2042 newXS("Win32::UnregisterServer", w32_UnregisterServer, file);
2043 newXS("Win32::GetArchName", w32_GetArchName, file);
2044 newXS("Win32::GetChipArch", w32_GetChipArch, file);
2045 newXS("Win32::GetChipName", w32_GetChipName, file);
2046 newXS("Win32::GuidGen", w32_GuidGen, file);
2047 newXS("Win32::GetFolderPath", w32_GetFolderPath, file);
2048 newXS("Win32::IsAdminUser", w32_IsAdminUser, file);
2049 newXS("Win32::GetFileVersion", w32_GetFileVersion, file);
2050
2051 newXS("Win32::GetCwd", w32_GetCwd, file);
2052 newXS("Win32::SetCwd", w32_SetCwd, file);
2053 newXS("Win32::GetNextAvailDrive", w32_GetNextAvailDrive, file);
2054 newXS("Win32::GetLastError", w32_GetLastError, file);
2055 newXS("Win32::SetLastError", w32_SetLastError, file);
2056 newXS("Win32::LoginName", w32_LoginName, file);
2057 newXS("Win32::NodeName", w32_NodeName, file);
2058 newXS("Win32::DomainName", w32_DomainName, file);
2059 newXS("Win32::FsType", w32_FsType, file);
2060 newXS("Win32::GetOSVersion", w32_GetOSVersion, file);
2061 newXS("Win32::IsWinNT", w32_IsWinNT, file);
2062 newXS("Win32::IsWin95", w32_IsWin95, file);
2063 newXS("Win32::FormatMessage", w32_FormatMessage, file);
2064 newXS("Win32::Spawn", w32_Spawn, file);
2065 newXS("Win32::GetTickCount", w32_GetTickCount, file);
2066 newXS("Win32::GetShortPathName", w32_GetShortPathName, file);
2067 newXS("Win32::GetFullPathName", w32_GetFullPathName, file);
2068 newXS("Win32::GetLongPathName", w32_GetLongPathName, file);
2069 newXS("Win32::GetANSIPathName", w32_GetANSIPathName, file);
2070 newXS("Win32::CopyFile", w32_CopyFile, file);
2071 newXS("Win32::Sleep", w32_Sleep, file);
2072 newXS("Win32::OutputDebugString", w32_OutputDebugString, file);
2073 newXS("Win32::GetCurrentProcessId", w32_GetCurrentProcessId, file);
2074 newXS("Win32::GetCurrentThreadId", w32_GetCurrentThreadId, file);
2075 newXS("Win32::CreateDirectory", w32_CreateDirectory, file);
2076 newXS("Win32::CreateFile", w32_CreateFile, file);
2077 newXS("Win32::GetSystemMetrics", w32_GetSystemMetrics, file);
2078 newXS("Win32::GetProductInfo", w32_GetProductInfo, file);
2079 newXS("Win32::GetACP", w32_GetACP, file);
2080 newXS("Win32::GetConsoleCP", w32_GetConsoleCP, file);
2081 newXS("Win32::GetConsoleOutputCP", w32_GetConsoleOutputCP, file);
2082 newXS("Win32::GetOEMCP", w32_GetOEMCP, file);
2083 newXS("Win32::SetConsoleCP", w32_SetConsoleCP, file);
2084 newXS("Win32::SetConsoleOutputCP", w32_SetConsoleOutputCP, file);
2085 newXS("Win32::GetProcessPrivileges", w32_GetProcessPrivileges, file);
2086 newXS("Win32::IsDeveloperModeEnabled", w32_IsDeveloperModeEnabled, file);
2087 #ifdef __CYGWIN__
2088 newXS("Win32::SetChildShowWindow", w32_SetChildShowWindow, file);
2089 #endif
2090 #ifdef WINHTTPAPI
2091 newXS("Win32::HttpGetFile", w32_HttpGetFile, file);
2092 #endif
2093 XSRETURN_YES;
2094 }
2095