This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Implement IO::Handle::say the same way as the builtin say().
[perl5.git] / ext / Win32 / Win32.xs
CommitLineData
34f7f30d 1#include <wctype.h>
b4ad57f4 2#include <windows.h>
34f7f30d 3#include <shlobj.h>
b4ad57f4 4
34f7f30d 5#define PERL_NO_GET_CONTEXT
b4ad57f4
NC
6#include "EXTERN.h"
7#include "perl.h"
8#include "XSUB.h"
9
34f7f30d
SH
10#ifndef countof
11# define countof(array) (sizeof (array) / sizeof (*(array)))
12#endif
13
b4ad57f4 14#define SE_SHUTDOWN_NAMEA "SeShutdownPrivilege"
b4ad57f4 15
34f7f30d
SH
16#ifndef WC_NO_BEST_FIT_CHARS
17# define WC_NO_BEST_FIT_CHARS 0x00000400
18#endif
19
20#define GETPROC(fn) pfn##fn = (PFN##fn)GetProcAddress(module, #fn)
21
22typedef BOOL (WINAPI *PFNSHGetSpecialFolderPathA)(HWND, char*, int, BOOL);
23typedef BOOL (WINAPI *PFNSHGetSpecialFolderPathW)(HWND, WCHAR*, int, BOOL);
24typedef HRESULT (WINAPI *PFNSHGetFolderPathA)(HWND, int, HANDLE, DWORD, LPTSTR);
25typedef HRESULT (WINAPI *PFNSHGetFolderPathW)(HWND, int, HANDLE, DWORD, LPWSTR);
26typedef BOOL (WINAPI *PFNCreateEnvironmentBlock)(void**, HANDLE, BOOL);
27typedef BOOL (WINAPI *PFNDestroyEnvironmentBlock)(void*);
5d477a6d
SH
28typedef int (__stdcall *PFNDllRegisterServer)(void);
29typedef int (__stdcall *PFNDllUnregisterServer)(void);
34f7f30d
SH
30typedef DWORD (__stdcall *PFNNetApiBufferFree)(void*);
31typedef DWORD (__stdcall *PFNNetWkstaGetInfo)(LPWSTR, DWORD, void*);
32
33typedef BOOL (__stdcall *PFNOpenProcessToken)(HANDLE, DWORD, HANDLE*);
34typedef BOOL (__stdcall *PFNOpenThreadToken)(HANDLE, DWORD, BOOL, HANDLE*);
35typedef BOOL (__stdcall *PFNGetTokenInformation)(HANDLE, TOKEN_INFORMATION_CLASS, void*, DWORD, DWORD*);
36typedef BOOL (__stdcall *PFNAllocateAndInitializeSid)(PSID_IDENTIFIER_AUTHORITY, BYTE, DWORD, DWORD,
37 DWORD, DWORD, DWORD, DWORD, DWORD, DWORD, PSID*);
38typedef BOOL (__stdcall *PFNEqualSid)(PSID, PSID);
39typedef void* (__stdcall *PFNFreeSid)(PSID);
0934c9d9 40typedef BOOL (__stdcall *PFNIsUserAnAdmin)(void);
34f7f30d 41
9c6a461f
DK
42#ifndef CSIDL_MYMUSIC
43# define CSIDL_MYMUSIC 0x000D
b4ad57f4 44#endif
9c6a461f
DK
45#ifndef CSIDL_MYVIDEO
46# define CSIDL_MYVIDEO 0x000E
47#endif
48#ifndef CSIDL_LOCAL_APPDATA
34f7f30d 49# define CSIDL_LOCAL_APPDATA 0x001C
9c6a461f
DK
50#endif
51#ifndef CSIDL_COMMON_FAVORITES
52# define CSIDL_COMMON_FAVORITES 0x001F
53#endif
54#ifndef CSIDL_INTERNET_CACHE
55# define CSIDL_INTERNET_CACHE 0x0020
56#endif
57#ifndef CSIDL_COOKIES
58# define CSIDL_COOKIES 0x0021
59#endif
60#ifndef CSIDL_HISTORY
61# define CSIDL_HISTORY 0x0022
62#endif
63#ifndef CSIDL_COMMON_APPDATA
64# define CSIDL_COMMON_APPDATA 0x0023
65#endif
66#ifndef CSIDL_WINDOWS
67# define CSIDL_WINDOWS 0x0024
68#endif
69#ifndef CSIDL_PROGRAM_FILES
70# define CSIDL_PROGRAM_FILES 0x0026
71#endif
72#ifndef CSIDL_MYPICTURES
34f7f30d 73# define CSIDL_MYPICTURES 0x0027
9c6a461f
DK
74#endif
75#ifndef CSIDL_PROFILE
34f7f30d 76# define CSIDL_PROFILE 0x0028
9c6a461f
DK
77#endif
78#ifndef CSIDL_PROGRAM_FILES_COMMON
34f7f30d 79# define CSIDL_PROGRAM_FILES_COMMON 0x002B
34f7f30d 80#endif
9c6a461f
DK
81#ifndef CSIDL_COMMON_TEMPLATES
82# define CSIDL_COMMON_TEMPLATES 0x002D
83#endif
84#ifndef CSIDL_COMMON_DOCUMENTS
85# define CSIDL_COMMON_DOCUMENTS 0x002E
86#endif
87#ifndef CSIDL_COMMON_ADMINTOOLS
88# define CSIDL_COMMON_ADMINTOOLS 0x002F
89#endif
90#ifndef CSIDL_ADMINTOOLS
91# define CSIDL_ADMINTOOLS 0x0030
34f7f30d 92#endif
34f7f30d
SH
93#ifndef CSIDL_COMMON_MUSIC
94# define CSIDL_COMMON_MUSIC 0x0035
95#endif
34f7f30d
SH
96#ifndef CSIDL_COMMON_PICTURES
97# define CSIDL_COMMON_PICTURES 0x0036
98#endif
34f7f30d
SH
99#ifndef CSIDL_COMMON_VIDEO
100# define CSIDL_COMMON_VIDEO 0x0037
101#endif
9c6a461f
DK
102#ifndef CSIDL_CDBURN_AREA
103# define CSIDL_CDBURN_AREA 0x003B
34f7f30d 104#endif
9c6a461f
DK
105#ifndef CSIDL_FLAG_CREATE
106# define CSIDL_FLAG_CREATE 0x8000
34f7f30d
SH
107#endif
108
109/* Use explicit struct definition because wSuiteMask and
110 * wProductType are not defined in the VC++ 6.0 headers.
111 * WORD type has been replaced by unsigned short because
112 * WORD is already used by Perl itself.
113 */
114struct {
115 DWORD dwOSVersionInfoSize;
116 DWORD dwMajorVersion;
117 DWORD dwMinorVersion;
118 DWORD dwBuildNumber;
119 DWORD dwPlatformId;
120 CHAR szCSDVersion[128];
121 unsigned short wServicePackMajor;
122 unsigned short wServicePackMinor;
123 unsigned short wSuiteMask;
124 BYTE wProductType;
125 BYTE wReserved;
126} g_osver = {0, 0, 0, 0, 0, "", 0, 0, 0, 0, 0};
127BOOL g_osver_ex = TRUE;
cf8b4e93
JD
128
129#define ONE_K_BUFSIZE 1024
130
131int
132IsWin95(void)
133{
134 return (g_osver.dwPlatformId == VER_PLATFORM_WIN32_WINDOWS);
135}
136
137int
138IsWinNT(void)
139{
140 return (g_osver.dwPlatformId == VER_PLATFORM_WIN32_NT);
141}
142
34f7f30d
SH
143int
144IsWin2000(void)
145{
146 return (g_osver.dwMajorVersion > 4);
147}
5bd7e777 148
34f7f30d
SH
149/* Convert SV to wide character string. The return value must be
150 * freed using Safefree().
151 */
152WCHAR*
153sv_to_wstr(pTHX_ SV *sv)
5bd7e777 154{
34f7f30d
SH
155 DWORD wlen;
156 WCHAR *wstr;
157 STRLEN len;
158 char *str = SvPV(sv, len);
159 UINT cp = SvUTF8(sv) ? CP_UTF8 : CP_ACP;
160
b5701e9e 161 wlen = MultiByteToWideChar(cp, 0, str, (int)(len+1), NULL, 0);
34f7f30d 162 New(0, wstr, wlen, WCHAR);
b5701e9e 163 MultiByteToWideChar(cp, 0, str, (int)(len+1), wstr, wlen);
34f7f30d
SH
164
165 return wstr;
166}
167
168/* Convert wide character string to mortal SV. Use UTF8 encoding
169 * if the string cannot be represented in the system codepage.
170 */
171SV *
172wstr_to_sv(pTHX_ WCHAR *wstr)
173{
b5701e9e 174 int wlen = (int)wcslen(wstr)+1;
34f7f30d
SH
175 BOOL use_default = FALSE;
176 int len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, wstr, wlen, NULL, 0, NULL, NULL);
177 SV *sv = sv_2mortal(newSV(len));
178
179 len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, wstr, wlen, SvPVX(sv), len, NULL, &use_default);
180 if (use_default) {
181 len = WideCharToMultiByte(CP_UTF8, 0, wstr, wlen, NULL, 0, NULL, NULL);
182 sv_grow(sv, len);
183 len = WideCharToMultiByte(CP_UTF8, 0, wstr, wlen, SvPVX(sv), len, NULL, NULL);
184 SvUTF8_on(sv);
5bd7e777 185 }
34f7f30d
SH
186 /* Shouldn't really ever fail since we ask for the required length first, but who knows... */
187 if (len) {
188 SvPOK_on(sv);
189 SvCUR_set(sv, len-1);
5bd7e777 190 }
34f7f30d
SH
191 return sv;
192}
5bd7e777 193
34f7f30d
SH
194/* Retrieve a variable from the Unicode environment in a mortal SV.
195 *
196 * Recreates the Unicode environment because a bug in earlier Perl versions
197 * overwrites it with the ANSI version, which contains replacement
198 * characters for the characters not in the ANSI codepage.
199 */
200SV*
201get_unicode_env(pTHX_ WCHAR *name)
202{
203 SV *sv = NULL;
204 void *env;
205 HANDLE token;
206 HMODULE module;
207 PFNOpenProcessToken pfnOpenProcessToken;
5bd7e777 208
34f7f30d
SH
209 /* Get security token for the current process owner */
210 module = LoadLibrary("advapi32.dll");
211 if (!module)
212 return NULL;
213
214 GETPROC(OpenProcessToken);
215
216 if (pfnOpenProcessToken == NULL ||
217 !pfnOpenProcessToken(GetCurrentProcess(), TOKEN_QUERY | TOKEN_DUPLICATE, &token))
218 {
219 FreeLibrary(module);
220 return NULL;
5bd7e777 221 }
34f7f30d
SH
222 FreeLibrary(module);
223
224 /* Create a Unicode environment block for this process */
225 module = LoadLibrary("userenv.dll");
226 if (module) {
227 PFNCreateEnvironmentBlock pfnCreateEnvironmentBlock;
228 PFNDestroyEnvironmentBlock pfnDestroyEnvironmentBlock;
229
230 GETPROC(CreateEnvironmentBlock);
231 GETPROC(DestroyEnvironmentBlock);
232
233 if (pfnCreateEnvironmentBlock && pfnDestroyEnvironmentBlock &&
234 pfnCreateEnvironmentBlock(&env, token, FALSE))
235 {
236 size_t name_len = wcslen(name);
237 WCHAR *entry = env;
238 while (*entry) {
239 size_t i;
240 size_t entry_len = wcslen(entry);
241 BOOL equal = (entry_len > name_len) && (entry[name_len] == '=');
242
243 for (i=0; equal && i < name_len; ++i)
244 equal = (towupper(entry[i]) == towupper(name[i]));
245
246 if (equal) {
247 sv = wstr_to_sv(aTHX_ entry+name_len+1);
248 break;
249 }
250 entry += entry_len+1;
251 }
252 pfnDestroyEnvironmentBlock(env);
253 }
254 FreeLibrary(module);
255 }
256 CloseHandle(token);
257 return sv;
5bd7e777
JD
258}
259
34f7f30d
SH
260/* Define both an ANSI and a Wide version of win32_longpath */
261
262#define CHAR_T char
263#define WIN32_FIND_DATA_T WIN32_FIND_DATAA
264#define FN_FINDFIRSTFILE FindFirstFileA
265#define FN_STRLEN strlen
266#define FN_STRCPY strcpy
267#define LONGPATH my_longpathA
268#include "longpath.inc"
269
270#define CHAR_T WCHAR
271#define WIN32_FIND_DATA_T WIN32_FIND_DATAW
272#define FN_FINDFIRSTFILE FindFirstFileW
273#define FN_STRLEN wcslen
274#define FN_STRCPY wcscpy
275#define LONGPATH my_longpathW
276#include "longpath.inc"
277
278/* The my_ansipath() function takes a Unicode filename and converts it
279 * into the current Windows codepage. If some characters cannot be mapped,
280 * then it will convert the short name instead.
281 *
282 * The buffer to the ansi pathname must be freed with Safefree() when it
283 * it no longer needed.
284 *
285 * The argument to my_ansipath() must exist before this function is
286 * called; otherwise there is no way to determine the short path name.
287 *
288 * Ideas for future refinement:
289 * - Only convert those segments of the path that are not in the current
290 * codepage, but leave the other segments in their long form.
291 * - If the resulting name is longer than MAX_PATH, start converting
292 * additional path segments into short names until the full name
293 * is shorter than MAX_PATH. Shorten the filename part last!
294 */
295
296/* This is a modified version of core Perl win32/win32.c(win32_ansipath).
297 * It uses New() etc. instead of win32_malloc().
298 */
299
300char *
301my_ansipath(const WCHAR *widename)
302{
303 char *name;
304 BOOL use_default = FALSE;
b5701e9e 305 int widelen = (int)wcslen(widename)+1;
34f7f30d
SH
306 int len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, widename, widelen,
307 NULL, 0, NULL, NULL);
308 New(0, name, len, char);
309 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, widename, widelen,
310 name, len, NULL, &use_default);
311 if (use_default) {
312 DWORD shortlen = GetShortPathNameW(widename, NULL, 0);
313 if (shortlen) {
314 WCHAR *shortname;
315 New(0, shortname, shortlen, WCHAR);
316 shortlen = GetShortPathNameW(widename, shortname, shortlen)+1;
317
318 len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, shortname, shortlen,
319 NULL, 0, NULL, NULL);
320 Renew(name, len, char);
321 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, shortname, shortlen,
322 name, len, NULL, NULL);
323 Safefree(shortname);
324 }
325 }
326 return name;
327}
328
329/* Convert wide character path to ANSI path and return as mortal SV. */
330SV*
331wstr_to_ansipath(pTHX_ WCHAR *wstr)
332{
333 char *ansi = my_ansipath(wstr);
334 SV *sv = sv_2mortal(newSVpvn(ansi, strlen(ansi)));
335 Safefree(ansi);
336 return sv;
337}
338
339#ifdef __CYGWIN__
340
5bd7e777
JD
341char*
342get_childdir(void)
343{
344 dTHX;
345 char* ptr;
5bd7e777 346
34f7f30d
SH
347 if (IsWin2000()) {
348 WCHAR filename[MAX_PATH+1];
349 GetCurrentDirectoryW(MAX_PATH+1, filename);
350 ptr = my_ansipath(filename);
351 }
352 else {
353 char filename[MAX_PATH+1];
354 GetCurrentDirectoryA(MAX_PATH+1, filename);
355 New(0, ptr, strlen(filename)+1, char);
356 strcpy(ptr, filename);
357 }
5bd7e777
JD
358 return ptr;
359}
360
361void
34f7f30d 362free_childdir(char *d)
5bd7e777
JD
363{
364 dTHX;
365 Safefree(d);
366}
367
368void*
369get_childenv(void)
370{
371 return NULL;
372}
373
374void
34f7f30d 375free_childenv(void *d)
5bd7e777
JD
376{
377}
378
379# define PerlDir_mapA(dir) (dir)
380
381#endif
382
b4ad57f4
NC
383XS(w32_ExpandEnvironmentStrings)
384{
385 dXSARGS;
b4ad57f4
NC
386
387 if (items != 1)
388 croak("usage: Win32::ExpandEnvironmentStrings($String);\n");
389
34f7f30d
SH
390 if (IsWin2000()) {
391 WCHAR value[31*1024];
392 WCHAR *source = sv_to_wstr(aTHX_ ST(0));
393 ExpandEnvironmentStringsW(source, value, countof(value)-1);
394 ST(0) = wstr_to_sv(aTHX_ value);
395 Safefree(source);
396 XSRETURN(1);
397 }
398 else {
399 char value[31*1024];
400 ExpandEnvironmentStringsA(SvPV_nolen(ST(0)), value, countof(value)-2);
401 XSRETURN_PV(value);
402 }
b4ad57f4
NC
403}
404
405XS(w32_IsAdminUser)
406{
407 dXSARGS;
34f7f30d
SH
408 HMODULE module;
409 PFNIsUserAnAdmin pfnIsUserAnAdmin;
410 PFNOpenThreadToken pfnOpenThreadToken;
411 PFNOpenProcessToken pfnOpenProcessToken;
412 PFNGetTokenInformation pfnGetTokenInformation;
413 PFNAllocateAndInitializeSid pfnAllocateAndInitializeSid;
414 PFNEqualSid pfnEqualSid;
415 PFNFreeSid pfnFreeSid;
b4ad57f4
NC
416 HANDLE hTok;
417 DWORD dwTokInfoLen;
418 TOKEN_GROUPS *lpTokInfo;
419 SID_IDENTIFIER_AUTHORITY NtAuth = SECURITY_NT_AUTHORITY;
420 PSID pAdminSid;
421 int iRetVal;
422 unsigned int i;
b4ad57f4
NC
423
424 if (items)
425 croak("usage: Win32::IsAdminUser()");
426
427 /* There is no concept of "Administrator" user accounts on Win9x systems,
428 so just return true. */
34f7f30d 429 if (IsWin95())
b4ad57f4
NC
430 XSRETURN_YES;
431
34f7f30d
SH
432 /* Use IsUserAnAdmin() when available. On Vista this will only return TRUE
433 * if the process is running with elevated privileges and not just when the
434 * process owner is a member of the "Administrators" group.
435 */
436 module = LoadLibrary("shell32.dll");
437 if (module) {
438 GETPROC(IsUserAnAdmin);
439 if (pfnIsUserAnAdmin) {
440 EXTEND(SP, 1);
441 ST(0) = sv_2mortal(newSViv(pfnIsUserAnAdmin() ? 1 : 0));
442 FreeLibrary(module);
443 XSRETURN(1);
444 }
445 FreeLibrary(module);
446 }
447
448 module = LoadLibrary("advapi32.dll");
449 if (!module) {
b4ad57f4
NC
450 warn("Cannot load advapi32.dll library");
451 XSRETURN_UNDEF;
452 }
453
34f7f30d
SH
454 GETPROC(OpenThreadToken);
455 GETPROC(OpenProcessToken);
456 GETPROC(GetTokenInformation);
457 GETPROC(AllocateAndInitializeSid);
458 GETPROC(EqualSid);
459 GETPROC(FreeSid);
b4ad57f4
NC
460
461 if (!(pfnOpenThreadToken && pfnOpenProcessToken &&
462 pfnGetTokenInformation && pfnAllocateAndInitializeSid &&
463 pfnEqualSid && pfnFreeSid))
464 {
465 warn("Cannot load functions from advapi32.dll library");
34f7f30d 466 FreeLibrary(module);
b4ad57f4
NC
467 XSRETURN_UNDEF;
468 }
469
470 if (!pfnOpenThreadToken(GetCurrentThread(), TOKEN_QUERY, FALSE, &hTok)) {
471 if (!pfnOpenProcessToken(GetCurrentProcess(), TOKEN_QUERY, &hTok)) {
472 warn("Cannot open thread token or process token");
34f7f30d 473 FreeLibrary(module);
b4ad57f4
NC
474 XSRETURN_UNDEF;
475 }
476 }
477
478 pfnGetTokenInformation(hTok, TokenGroups, NULL, 0, &dwTokInfoLen);
479 if (!New(1, lpTokInfo, dwTokInfoLen, TOKEN_GROUPS)) {
480 warn("Cannot allocate token information structure");
481 CloseHandle(hTok);
34f7f30d 482 FreeLibrary(module);
b4ad57f4
NC
483 XSRETURN_UNDEF;
484 }
485
486 if (!pfnGetTokenInformation(hTok, TokenGroups, lpTokInfo, dwTokInfoLen,
487 &dwTokInfoLen))
488 {
489 warn("Cannot get token information");
490 Safefree(lpTokInfo);
491 CloseHandle(hTok);
34f7f30d 492 FreeLibrary(module);
b4ad57f4
NC
493 XSRETURN_UNDEF;
494 }
495
496 if (!pfnAllocateAndInitializeSid(&NtAuth, 2, SECURITY_BUILTIN_DOMAIN_RID,
497 DOMAIN_ALIAS_RID_ADMINS, 0, 0, 0, 0, 0, 0, &pAdminSid))
498 {
499 warn("Cannot allocate administrators' SID");
500 Safefree(lpTokInfo);
501 CloseHandle(hTok);
34f7f30d 502 FreeLibrary(module);
b4ad57f4
NC
503 XSRETURN_UNDEF;
504 }
505
506 iRetVal = 0;
507 for (i = 0; i < lpTokInfo->GroupCount; ++i) {
508 if (pfnEqualSid(lpTokInfo->Groups[i].Sid, pAdminSid)) {
509 iRetVal = 1;
510 break;
511 }
512 }
513
514 pfnFreeSid(pAdminSid);
515 Safefree(lpTokInfo);
516 CloseHandle(hTok);
34f7f30d 517 FreeLibrary(module);
b4ad57f4
NC
518
519 EXTEND(SP, 1);
520 ST(0) = sv_2mortal(newSViv(iRetVal));
521 XSRETURN(1);
522}
523
524XS(w32_LookupAccountName)
525{
526 dXSARGS;
527 char SID[400];
528 DWORD SIDLen;
529 SID_NAME_USE snu;
530 char Domain[256];
531 DWORD DomLen;
b4ad57f4 532 BOOL bResult;
8c56068e 533
b4ad57f4
NC
534 if (items != 5)
535 croak("usage: Win32::LookupAccountName($system, $account, $domain, "
536 "$sid, $sidtype);\n");
537
538 SIDLen = sizeof(SID);
539 DomLen = sizeof(Domain);
540
8c56068e
JD
541 bResult = LookupAccountNameA(SvPV_nolen(ST(0)), /* System */
542 SvPV_nolen(ST(1)), /* Account name */
543 &SID, /* SID structure */
544 &SIDLen, /* Size of SID buffer */
545 Domain, /* Domain buffer */
546 &DomLen, /* Domain buffer size */
547 &snu); /* SID name type */
b4ad57f4
NC
548 if (bResult) {
549 sv_setpv(ST(2), Domain);
550 sv_setpvn(ST(3), SID, SIDLen);
551 sv_setiv(ST(4), snu);
552 XSRETURN_YES;
553 }
8c56068e
JD
554 XSRETURN_NO;
555}
b4ad57f4
NC
556
557
558XS(w32_LookupAccountSID)
559{
560 dXSARGS;
561 PSID sid;
562 char Account[256];
563 DWORD AcctLen = sizeof(Account);
564 char Domain[256];
565 DWORD DomLen = sizeof(Domain);
566 SID_NAME_USE snu;
b4ad57f4
NC
567 BOOL bResult;
568
569 if (items != 5)
570 croak("usage: Win32::LookupAccountSID($system, $sid, $account, $domain, $sidtype);\n");
571
8c56068e 572 sid = SvPV_nolen(ST(1));
b4ad57f4 573 if (IsValidSid(sid)) {
8c56068e
JD
574 bResult = LookupAccountSidA(SvPV_nolen(ST(0)), /* System */
575 sid, /* SID structure */
576 Account, /* Account name buffer */
577 &AcctLen, /* name buffer length */
578 Domain, /* Domain buffer */
579 &DomLen, /* Domain buffer length */
580 &snu); /* SID name type */
b4ad57f4
NC
581 if (bResult) {
582 sv_setpv(ST(2), Account);
583 sv_setpv(ST(3), Domain);
584 sv_setiv(ST(4), (IV)snu);
585 XSRETURN_YES;
586 }
b4ad57f4 587 }
8c56068e
JD
588 XSRETURN_NO;
589}
b4ad57f4
NC
590
591XS(w32_InitiateSystemShutdown)
592{
593 dXSARGS;
594 HANDLE hToken; /* handle to process token */
595 TOKEN_PRIVILEGES tkp; /* pointer to token structure */
596 BOOL bRet;
b4ad57f4 597 char *machineName, *message;
b4ad57f4
NC
598
599 if (items != 5)
600 croak("usage: Win32::InitiateSystemShutdown($machineName, $message, "
601 "$timeOut, $forceClose, $reboot);\n");
602
8c56068e 603 machineName = SvPV_nolen(ST(0));
b4ad57f4
NC
604
605 if (OpenProcessToken(GetCurrentProcess(),
606 TOKEN_ADJUST_PRIVILEGES | TOKEN_QUERY,
607 &hToken))
608 {
8c56068e
JD
609 LookupPrivilegeValueA(machineName,
610 SE_SHUTDOWN_NAMEA,
611 &tkp.Privileges[0].Luid);
b4ad57f4
NC
612
613 tkp.PrivilegeCount = 1; /* only setting one */
614 tkp.Privileges[0].Attributes = SE_PRIVILEGE_ENABLED;
615
616 /* Get shutdown privilege for this process. */
617 AdjustTokenPrivileges(hToken, FALSE, &tkp, 0,
618 (PTOKEN_PRIVILEGES)NULL, 0);
619 }
620
8c56068e 621 message = SvPV_nolen(ST(1));
b5701e9e
SH
622 bRet = InitiateSystemShutdownA(machineName, message, (DWORD)SvIV(ST(2)),
623 (BOOL)SvIV(ST(3)), (BOOL)SvIV(ST(4)));
b4ad57f4
NC
624
625 /* Disable shutdown privilege. */
626 tkp.Privileges[0].Attributes = 0;
627 AdjustTokenPrivileges(hToken, FALSE, &tkp, 0,
628 (PTOKEN_PRIVILEGES)NULL, 0);
629 CloseHandle(hToken);
630 XSRETURN_IV(bRet);
631}
632
633XS(w32_AbortSystemShutdown)
634{
635 dXSARGS;
636 HANDLE hToken; /* handle to process token */
637 TOKEN_PRIVILEGES tkp; /* pointer to token structure */
638 BOOL bRet;
639 char *machineName;
b4ad57f4
NC
640
641 if (items != 1)
642 croak("usage: Win32::AbortSystemShutdown($machineName);\n");
643
8c56068e 644 machineName = SvPV_nolen(ST(0));
b4ad57f4
NC
645
646 if (OpenProcessToken(GetCurrentProcess(),
647 TOKEN_ADJUST_PRIVILEGES | TOKEN_QUERY,
648 &hToken))
649 {
8c56068e
JD
650 LookupPrivilegeValueA(machineName,
651 SE_SHUTDOWN_NAMEA,
652 &tkp.Privileges[0].Luid);
b4ad57f4
NC
653
654 tkp.PrivilegeCount = 1; /* only setting one */
655 tkp.Privileges[0].Attributes = SE_PRIVILEGE_ENABLED;
656
657 /* Get shutdown privilege for this process. */
658 AdjustTokenPrivileges(hToken, FALSE, &tkp, 0,
659 (PTOKEN_PRIVILEGES)NULL, 0);
660 }
661
8c56068e 662 bRet = AbortSystemShutdownA(machineName);
b4ad57f4
NC
663
664 /* Disable shutdown privilege. */
665 tkp.Privileges[0].Attributes = 0;
666 AdjustTokenPrivileges(hToken, FALSE, &tkp, 0,
667 (PTOKEN_PRIVILEGES)NULL, 0);
668 CloseHandle(hToken);
669 XSRETURN_IV(bRet);
670}
671
672
673XS(w32_MsgBox)
674{
675 dXSARGS;
b4ad57f4 676 DWORD flags = MB_ICONEXCLAMATION;
b4ad57f4
NC
677 I32 result;
678
679 if (items < 1 || items > 3)
680 croak("usage: Win32::MsgBox($message [, $flags [, $title]]);\n");
681
34f7f30d 682 if (items > 1)
b5701e9e 683 flags = (DWORD)SvIV(ST(1));
34f7f30d
SH
684
685 if (IsWin2000()) {
686 WCHAR *title = NULL;
687 WCHAR *msg = sv_to_wstr(aTHX_ ST(0));
688 if (items > 2)
689 title = sv_to_wstr(aTHX_ ST(2));
690 result = MessageBoxW(GetActiveWindow(), msg, title ? title : L"Perl", flags);
691 Safefree(msg);
692 if (title)
693 Safefree(title);
694 }
695 else {
696 char *title = "Perl";
697 char *msg = SvPV_nolen(ST(0));
698 if (items > 2)
699 title = SvPV_nolen(ST(2));
700 result = MessageBoxA(GetActiveWindow(), msg, title, flags);
b4ad57f4 701 }
b4ad57f4
NC
702 XSRETURN_IV(result);
703}
704
705XS(w32_LoadLibrary)
706{
707 dXSARGS;
b4ad57f4 708 HANDLE hHandle;
b4ad57f4
NC
709
710 if (items != 1)
711 croak("usage: Win32::LoadLibrary($libname)\n");
8c56068e 712 hHandle = LoadLibraryA(SvPV_nolen(ST(0)));
b5701e9e
SH
713#ifdef _WIN64
714 XSRETURN_IV((DWORD_PTR)hHandle);
715#else
716 XSRETURN_IV((DWORD)hHandle);
717#endif
b4ad57f4
NC
718}
719
720XS(w32_FreeLibrary)
721{
722 dXSARGS;
8c56068e 723
b4ad57f4
NC
724 if (items != 1)
725 croak("usage: Win32::FreeLibrary($handle)\n");
8c56068e 726 if (FreeLibrary(INT2PTR(HINSTANCE, SvIV(ST(0))))) {
b4ad57f4
NC
727 XSRETURN_YES;
728 }
729 XSRETURN_NO;
730}
731
732XS(w32_GetProcAddress)
733{
734 dXSARGS;
8c56068e 735
b4ad57f4
NC
736 if (items != 2)
737 croak("usage: Win32::GetProcAddress($hinstance, $procname)\n");
8c56068e 738 XSRETURN_IV(PTR2IV(GetProcAddress(INT2PTR(HINSTANCE, SvIV(ST(0))), SvPV_nolen(ST(1)))));
b4ad57f4
NC
739}
740
741XS(w32_RegisterServer)
742{
743 dXSARGS;
744 BOOL result = FALSE;
34f7f30d 745 HMODULE module;
b4ad57f4
NC
746
747 if (items != 1)
748 croak("usage: Win32::RegisterServer($libname)\n");
749
34f7f30d
SH
750 module = LoadLibraryA(SvPV_nolen(ST(0)));
751 if (module) {
752 PFNDllRegisterServer pfnDllRegisterServer;
753 GETPROC(DllRegisterServer);
754 if (pfnDllRegisterServer && pfnDllRegisterServer() == 0)
b4ad57f4 755 result = TRUE;
34f7f30d 756 FreeLibrary(module);
b4ad57f4 757 }
8c56068e
JD
758 ST(0) = boolSV(result);
759 XSRETURN(1);
b4ad57f4
NC
760}
761
762XS(w32_UnregisterServer)
763{
764 dXSARGS;
765 BOOL result = FALSE;
34f7f30d 766 HINSTANCE module;
b4ad57f4
NC
767
768 if (items != 1)
769 croak("usage: Win32::UnregisterServer($libname)\n");
770
34f7f30d
SH
771 module = LoadLibraryA(SvPV_nolen(ST(0)));
772 if (module) {
773 PFNDllUnregisterServer pfnDllUnregisterServer;
774 GETPROC(DllUnregisterServer);
775 if (pfnDllUnregisterServer && pfnDllUnregisterServer() == 0)
b4ad57f4 776 result = TRUE;
34f7f30d 777 FreeLibrary(module);
b4ad57f4 778 }
8c56068e
JD
779 ST(0) = boolSV(result);
780 XSRETURN(1);
b4ad57f4
NC
781}
782
783/* XXX rather bogus */
784XS(w32_GetArchName)
785{
786 dXSARGS;
787 XSRETURN_PV(getenv("PROCESSOR_ARCHITECTURE"));
788}
789
790XS(w32_GetChipName)
791{
792 dXSARGS;
793 SYSTEM_INFO sysinfo;
794
795 Zero(&sysinfo,1,SYSTEM_INFO);
796 GetSystemInfo(&sysinfo);
797 /* XXX docs say dwProcessorType is deprecated on NT */
798 XSRETURN_IV(sysinfo.dwProcessorType);
799}
800
801XS(w32_GuidGen)
802{
803 dXSARGS;
804 GUID guid;
805 char szGUID[50] = {'\0'};
806 HRESULT hr = CoCreateGuid(&guid);
807
808 if (SUCCEEDED(hr)) {
809 LPOLESTR pStr = NULL;
e364e11c 810 if (SUCCEEDED(StringFromCLSID(&guid, &pStr))) {
b5701e9e 811 WideCharToMultiByte(CP_ACP, 0, pStr, (int)wcslen(pStr), szGUID,
e364e11c
JD
812 sizeof(szGUID), NULL, NULL);
813 CoTaskMemFree(pStr);
814 XSRETURN_PV(szGUID);
815 }
b4ad57f4 816 }
e364e11c 817 XSRETURN_UNDEF;
b4ad57f4
NC
818}
819
820XS(w32_GetFolderPath)
821{
822 dXSARGS;
823 char path[MAX_PATH+1];
34f7f30d 824 WCHAR wpath[MAX_PATH+1];
b4ad57f4
NC
825 int folder;
826 int create = 0;
827 HMODULE module;
828
829 if (items != 1 && items != 2)
830 croak("usage: Win32::GetFolderPath($csidl [, $create])\n");
831
b5701e9e 832 folder = (int)SvIV(ST(0));
b4ad57f4
NC
833 if (items == 2)
834 create = SvTRUE(ST(1)) ? CSIDL_FLAG_CREATE : 0;
835
b4ad57f4
NC
836 module = LoadLibrary("shfolder.dll");
837 if (module) {
34f7f30d
SH
838 PFNSHGetFolderPathA pfna;
839 if (IsWin2000()) {
840 PFNSHGetFolderPathW pfnw;
841 pfnw = (PFNSHGetFolderPathW)GetProcAddress(module, "SHGetFolderPathW");
842 if (pfnw && SUCCEEDED(pfnw(NULL, folder|create, NULL, 0, wpath))) {
843 FreeLibrary(module);
844 ST(0) = wstr_to_ansipath(aTHX_ wpath);
845 XSRETURN(1);
846 }
847 }
848 pfna = (PFNSHGetFolderPathA)GetProcAddress(module, "SHGetFolderPathA");
849 if (pfna && SUCCEEDED(pfna(NULL, folder|create, NULL, 0, path))) {
b4ad57f4
NC
850 FreeLibrary(module);
851 XSRETURN_PV(path);
852 }
853 FreeLibrary(module);
854 }
855
856 module = LoadLibrary("shell32.dll");
857 if (module) {
34f7f30d
SH
858 PFNSHGetSpecialFolderPathA pfna;
859 if (IsWin2000()) {
860 PFNSHGetSpecialFolderPathW pfnw;
861 pfnw = (PFNSHGetSpecialFolderPathW)GetProcAddress(module, "SHGetSpecialFolderPathW");
862 if (pfnw && pfnw(NULL, wpath, folder, !!create)) {
863 FreeLibrary(module);
864 ST(0) = wstr_to_ansipath(aTHX_ wpath);
865 XSRETURN(1);
866 }
867 }
868 pfna = (PFNSHGetSpecialFolderPathA)GetProcAddress(module, "SHGetSpecialFolderPathA");
869 if (pfna && pfna(NULL, path, folder, !!create)) {
b4ad57f4
NC
870 FreeLibrary(module);
871 XSRETURN_PV(path);
872 }
873 FreeLibrary(module);
874 }
34f7f30d
SH
875
876 /* SHGetFolderPathW() and SHGetSpecialFolderPathW() may fail on older
877 * Perl versions that have replaced the Unicode environment with an
878 * ANSI version. Let's go spelunking in the registry now...
879 */
880 if (IsWin2000()) {
881 SV *sv;
882 HKEY hkey;
883 HKEY root = HKEY_CURRENT_USER;
884 WCHAR *name = NULL;
885
886 switch (folder) {
887 case CSIDL_ADMINTOOLS: name = L"Administrative Tools"; break;
888 case CSIDL_APPDATA: name = L"AppData"; break;
889 case CSIDL_CDBURN_AREA: name = L"CD Burning"; break;
890 case CSIDL_COOKIES: name = L"Cookies"; break;
891 case CSIDL_DESKTOP:
892 case CSIDL_DESKTOPDIRECTORY: name = L"Desktop"; break;
893 case CSIDL_FAVORITES: name = L"Favorites"; break;
894 case CSIDL_FONTS: name = L"Fonts"; break;
895 case CSIDL_HISTORY: name = L"History"; break;
896 case CSIDL_INTERNET_CACHE: name = L"Cache"; break;
897 case CSIDL_LOCAL_APPDATA: name = L"Local AppData"; break;
898 case CSIDL_MYMUSIC: name = L"My Music"; break;
899 case CSIDL_MYPICTURES: name = L"My Pictures"; break;
900 case CSIDL_MYVIDEO: name = L"My Video"; break;
901 case CSIDL_NETHOOD: name = L"NetHood"; break;
902 case CSIDL_PERSONAL: name = L"Personal"; break;
903 case CSIDL_PRINTHOOD: name = L"PrintHood"; break;
904 case CSIDL_PROGRAMS: name = L"Programs"; break;
905 case CSIDL_RECENT: name = L"Recent"; break;
906 case CSIDL_SENDTO: name = L"SendTo"; break;
907 case CSIDL_STARTMENU: name = L"Start Menu"; break;
908 case CSIDL_STARTUP: name = L"Startup"; break;
909 case CSIDL_TEMPLATES: name = L"Templates"; break;
910 /* XXX L"Local Settings" */
911 }
912
913 if (!name) {
914 root = HKEY_LOCAL_MACHINE;
915 switch (folder) {
916 case CSIDL_COMMON_ADMINTOOLS: name = L"Common Administrative Tools"; break;
917 case CSIDL_COMMON_APPDATA: name = L"Common AppData"; break;
918 case CSIDL_COMMON_DESKTOPDIRECTORY: name = L"Common Desktop"; break;
919 case CSIDL_COMMON_DOCUMENTS: name = L"Common Documents"; break;
920 case CSIDL_COMMON_FAVORITES: name = L"Common Favorites"; break;
921 case CSIDL_COMMON_PROGRAMS: name = L"Common Programs"; break;
922 case CSIDL_COMMON_STARTMENU: name = L"Common Start Menu"; break;
923 case CSIDL_COMMON_STARTUP: name = L"Common Startup"; break;
924 case CSIDL_COMMON_TEMPLATES: name = L"Common Templates"; break;
925 case CSIDL_COMMON_MUSIC: name = L"CommonMusic"; break;
926 case CSIDL_COMMON_PICTURES: name = L"CommonPictures"; break;
927 case CSIDL_COMMON_VIDEO: name = L"CommonVideo"; break;
928 }
929 }
930 /* XXX todo
931 * case CSIDL_SYSTEM # GetSystemDirectory()
932 * case CSIDL_RESOURCES # %windir%\Resources\, For theme and other windows resources.
933 * case CSIDL_RESOURCES_LOCALIZED # %windir%\Resources\<LangID>, for theme and other windows specific resources.
934 */
935
936#define SHELL_FOLDERS "Software\\Microsoft\\Windows\\CurrentVersion\\Explorer\\Shell Folders"
937
938 if (name && RegOpenKeyEx(root, SHELL_FOLDERS, 0, KEY_QUERY_VALUE, &hkey) == ERROR_SUCCESS) {
939 WCHAR data[MAX_PATH+1];
940 DWORD cb = sizeof(data)-sizeof(WCHAR);
941 DWORD type = REG_NONE;
942 long rc = RegQueryValueExW(hkey, name, NULL, &type, (BYTE*)&data, &cb);
943 RegCloseKey(hkey);
944 if (rc == ERROR_SUCCESS && type == REG_SZ && cb > sizeof(WCHAR) && data[0]) {
945 /* Make sure the string is properly terminated */
946 data[cb/sizeof(WCHAR)] = '\0';
947 ST(0) = wstr_to_ansipath(aTHX_ data);
948 XSRETURN(1);
949 }
950 }
951
952#undef SHELL_FOLDERS
953
954 /* Unders some circumstances the registry entries seem to have a null string
955 * as their value even when the directory already exists. The environment
956 * variables do get set though, so try re-create a Unicode environment and
957 * check if they are there.
958 */
959 sv = NULL;
960 switch (folder) {
961 case CSIDL_APPDATA: sv = get_unicode_env(aTHX_ L"APPDATA"); break;
962 case CSIDL_PROFILE: sv = get_unicode_env(aTHX_ L"USERPROFILE"); break;
963 case CSIDL_PROGRAM_FILES: sv = get_unicode_env(aTHX_ L"ProgramFiles"); break;
964 case CSIDL_PROGRAM_FILES_COMMON: sv = get_unicode_env(aTHX_ L"CommonProgramFiles"); break;
965 case CSIDL_WINDOWS: sv = get_unicode_env(aTHX_ L"SystemRoot"); break;
966 }
967 if (sv) {
968 ST(0) = sv;
969 XSRETURN(1);
970 }
971 }
972
b4ad57f4
NC
973 XSRETURN_UNDEF;
974}
975
e364e11c
JD
976XS(w32_GetFileVersion)
977{
978 dXSARGS;
979 DWORD size;
980 DWORD handle;
981 char *filename;
982 char *data;
983
984 if (items != 1)
985 croak("usage: Win32::GetFileVersion($filename)\n");
986
987 filename = SvPV_nolen(ST(0));
988 size = GetFileVersionInfoSize(filename, &handle);
989 if (!size)
990 XSRETURN_UNDEF;
991
992 New(0, data, size, char);
993 if (!data)
994 XSRETURN_UNDEF;
995
996 if (GetFileVersionInfo(filename, handle, size, data)) {
997 VS_FIXEDFILEINFO *info;
998 UINT len;
999 if (VerQueryValue(data, "\\", (void**)&info, &len)) {
1000 int dwValueMS1 = (info->dwFileVersionMS>>16);
1001 int dwValueMS2 = (info->dwFileVersionMS&0xffff);
1002 int dwValueLS1 = (info->dwFileVersionLS>>16);
1003 int dwValueLS2 = (info->dwFileVersionLS&0xffff);
1004
1005 if (GIMME_V == G_ARRAY) {
1006 EXTEND(SP, 4);
1007 XST_mIV(0, dwValueMS1);
1008 XST_mIV(1, dwValueMS2);
1009 XST_mIV(2, dwValueLS1);
1010 XST_mIV(3, dwValueLS2);
1011 items = 4;
1012 }
1013 else {
1014 char version[50];
1015 sprintf(version, "%d.%d.%d.%d", dwValueMS1, dwValueMS2, dwValueLS1, dwValueLS2);
1016 XST_mPV(0, version);
1017 }
1018 }
1019 }
1020 else
1021 items = 0;
1022
1023 Safefree(data);
1024 XSRETURN(items);
1025}
1026
5bd7e777 1027#ifdef __CYGWIN__
cf8b4e93
JD
1028XS(w32_SetChildShowWindow)
1029{
5bd7e777
JD
1030 /* This function doesn't do anything useful for cygwin. In the
1031 * MSWin32 case it modifies w32_showwindow, which is used by
1032 * win32_spawnvp(). Since w32_showwindow is an internal variable
1033 * inside the thread_intern structure, the MSWin32 implementation
1034 * lives in win32/win32.c in the core Perl distribution.
1035 */
cf8b4e93 1036 dXSARGS;
5bd7e777 1037 XSRETURN_UNDEF;
cf8b4e93 1038}
5bd7e777 1039#endif
cf8b4e93 1040
cf8b4e93
JD
1041XS(w32_GetCwd)
1042{
1043 dXSARGS;
1044 /* Make the host for current directory */
1045 char* ptr = PerlEnv_get_childdir();
1046 /*
1047 * If ptr != Nullch
1048 * then it worked, set PV valid,
1049 * else return 'undef'
1050 */
1051 if (ptr) {
1052 SV *sv = sv_newmortal();
1053 sv_setpv(sv, ptr);
1054 PerlEnv_free_childdir(ptr);
1055
1056#ifndef INCOMPLETE_TAINTS
1057 SvTAINTED_on(sv);
1058#endif
1059
1060 EXTEND(SP,1);
cf8b4e93
JD
1061 ST(0) = sv;
1062 XSRETURN(1);
1063 }
1064 XSRETURN_UNDEF;
1065}
1066
cf8b4e93
JD
1067XS(w32_SetCwd)
1068{
1069 dXSARGS;
1070 if (items != 1)
34f7f30d
SH
1071 Perl_croak(aTHX_ "usage: Win32::SetCwd($cwd)");
1072
1073 if (IsWin2000() && SvUTF8(ST(0))) {
1074 WCHAR *wide = sv_to_wstr(aTHX_ ST(0));
1075 char *ansi = my_ansipath(wide);
1076 int rc = PerlDir_chdir(ansi);
1077 Safefree(wide);
1078 Safefree(ansi);
1079 if (!rc)
1080 XSRETURN_YES;
1081 }
1082 else {
1083 if (!PerlDir_chdir(SvPV_nolen(ST(0))))
1084 XSRETURN_YES;
1085 }
cf8b4e93
JD
1086
1087 XSRETURN_NO;
1088}
1089
cf8b4e93
JD
1090XS(w32_GetNextAvailDrive)
1091{
1092 dXSARGS;
1093 char ix = 'C';
1094 char root[] = "_:\\";
1095
1096 EXTEND(SP,1);
1097 while (ix <= 'Z') {
1098 root[0] = ix++;
1099 if (GetDriveType(root) == 1) {
1100 root[2] = '\0';
1101 XSRETURN_PV(root);
1102 }
1103 }
1104 XSRETURN_UNDEF;
1105}
1106
cf8b4e93
JD
1107XS(w32_GetLastError)
1108{
1109 dXSARGS;
1110 EXTEND(SP,1);
1111 XSRETURN_IV(GetLastError());
1112}
1113
cf8b4e93
JD
1114XS(w32_SetLastError)
1115{
1116 dXSARGS;
1117 if (items != 1)
1118 Perl_croak(aTHX_ "usage: Win32::SetLastError($error)");
b5701e9e 1119 SetLastError((DWORD)SvIV(ST(0)));
cf8b4e93
JD
1120 XSRETURN_EMPTY;
1121}
1122
cf8b4e93
JD
1123XS(w32_LoginName)
1124{
1125 dXSARGS;
cf8b4e93 1126 EXTEND(SP,1);
34f7f30d
SH
1127 if (IsWin2000()) {
1128 WCHAR name[128];
1129 DWORD size = countof(name);
1130 if (GetUserNameW(name, &size)) {
1131 ST(0) = wstr_to_sv(aTHX_ name);
1132 XSRETURN(1);
1133 }
1134 }
1135 else {
1136 char name[128];
1137 DWORD size = countof(name);
1138 if (GetUserNameA(name, &size)) {
1139 /* size includes NULL */
1140 ST(0) = sv_2mortal(newSVpvn(name, size-1));
1141 XSRETURN(1);
1142 }
cf8b4e93
JD
1143 }
1144 XSRETURN_UNDEF;
1145}
1146
cf8b4e93
JD
1147XS(w32_NodeName)
1148{
1149 dXSARGS;
1150 char name[MAX_COMPUTERNAME_LENGTH+1];
1151 DWORD size = sizeof(name);
1152 EXTEND(SP,1);
1153 if (GetComputerName(name,&size)) {
1154 /* size does NOT include NULL :-( */
1155 ST(0) = sv_2mortal(newSVpvn(name,size));
1156 XSRETURN(1);
1157 }
1158 XSRETURN_UNDEF;
1159}
1160
1161
cf8b4e93
JD
1162XS(w32_DomainName)
1163{
1164 dXSARGS;
34f7f30d
SH
1165 HMODULE module = LoadLibrary("netapi32.dll");
1166 PFNNetApiBufferFree pfnNetApiBufferFree;
1167 PFNNetWkstaGetInfo pfnNetWkstaGetInfo;
1168
1169 if (module) {
1170 GETPROC(NetApiBufferFree);
1171 GETPROC(NetWkstaGetInfo);
cf8b4e93
JD
1172 }
1173 EXTEND(SP,1);
34f7f30d 1174 if (module && pfnNetWkstaGetInfo && pfnNetApiBufferFree) {
cf8b4e93
JD
1175 /* this way is more reliable, in case user has a local account. */
1176 char dname[256];
1177 DWORD dnamelen = sizeof(dname);
1178 struct {
1179 DWORD wki100_platform_id;
1180 LPWSTR wki100_computername;
1181 LPWSTR wki100_langroup;
1182 DWORD wki100_ver_major;
1183 DWORD wki100_ver_minor;
1184 } *pwi;
166cd87e
SH
1185 DWORD retval;
1186 retval = pfnNetWkstaGetInfo(NULL, 100, &pwi);
cf8b4e93 1187 /* NERR_Success *is* 0*/
166cd87e 1188 if (retval == 0) {
cf8b4e93
JD
1189 if (pwi->wki100_langroup && *(pwi->wki100_langroup)) {
1190 WideCharToMultiByte(CP_ACP, 0, pwi->wki100_langroup,
1191 -1, (LPSTR)dname, dnamelen, NULL, NULL);
1192 }
1193 else {
1194 WideCharToMultiByte(CP_ACP, 0, pwi->wki100_computername,
1195 -1, (LPSTR)dname, dnamelen, NULL, NULL);
1196 }
1197 pfnNetApiBufferFree(pwi);
34f7f30d 1198 FreeLibrary(module);
cf8b4e93
JD
1199 XSRETURN_PV(dname);
1200 }
34f7f30d 1201 FreeLibrary(module);
166cd87e 1202 SetLastError(retval);
cf8b4e93
JD
1203 }
1204 else {
1205 /* Win95 doesn't have NetWksta*(), so do it the old way */
1206 char name[256];
1207 DWORD size = sizeof(name);
34f7f30d
SH
1208 if (module)
1209 FreeLibrary(module);
cf8b4e93
JD
1210 if (GetUserName(name,&size)) {
1211 char sid[ONE_K_BUFSIZE];
1212 DWORD sidlen = sizeof(sid);
1213 char dname[256];
1214 DWORD dnamelen = sizeof(dname);
1215 SID_NAME_USE snu;
1216 if (LookupAccountName(NULL, name, (PSID)&sid, &sidlen,
1217 dname, &dnamelen, &snu)) {
1218 XSRETURN_PV(dname); /* all that for this */
1219 }
1220 }
1221 }
1222 XSRETURN_UNDEF;
1223}
1224
cf8b4e93
JD
1225XS(w32_FsType)
1226{
1227 dXSARGS;
1228 char fsname[256];
1229 DWORD flags, filecomplen;
1230 if (GetVolumeInformation(NULL, NULL, 0, NULL, &filecomplen,
1231 &flags, fsname, sizeof(fsname))) {
1232 if (GIMME_V == G_ARRAY) {
1233 XPUSHs(sv_2mortal(newSVpvn(fsname,strlen(fsname))));
1234 XPUSHs(sv_2mortal(newSViv(flags)));
1235 XPUSHs(sv_2mortal(newSViv(filecomplen)));
1236 PUTBACK;
1237 return;
1238 }
1239 EXTEND(SP,1);
1240 XSRETURN_PV(fsname);
1241 }
1242 XSRETURN_EMPTY;
1243}
1244
cf8b4e93
JD
1245XS(w32_GetOSVersion)
1246{
1247 dXSARGS;
34f7f30d 1248
cf8b4e93 1249 if (GIMME_V == G_SCALAR) {
34f7f30d 1250 XSRETURN_IV(g_osver.dwPlatformId);
cf8b4e93 1251 }
159fce98 1252 XPUSHs(sv_2mortal(newSVpvn(g_osver.szCSDVersion, strlen(g_osver.szCSDVersion))));
34f7f30d 1253
159fce98
SH
1254 XPUSHs(sv_2mortal(newSViv(g_osver.dwMajorVersion)));
1255 XPUSHs(sv_2mortal(newSViv(g_osver.dwMinorVersion)));
1256 XPUSHs(sv_2mortal(newSViv(g_osver.dwBuildNumber)));
1257 XPUSHs(sv_2mortal(newSViv(g_osver.dwPlatformId)));
34f7f30d 1258 if (g_osver_ex) {
159fce98
SH
1259 XPUSHs(sv_2mortal(newSViv(g_osver.wServicePackMajor)));
1260 XPUSHs(sv_2mortal(newSViv(g_osver.wServicePackMinor)));
1261 XPUSHs(sv_2mortal(newSViv(g_osver.wSuiteMask)));
1262 XPUSHs(sv_2mortal(newSViv(g_osver.wProductType)));
cf8b4e93
JD
1263 }
1264 PUTBACK;
1265}
1266
cf8b4e93
JD
1267XS(w32_IsWinNT)
1268{
1269 dXSARGS;
1270 EXTEND(SP,1);
1271 XSRETURN_IV(IsWinNT());
1272}
1273
cf8b4e93
JD
1274XS(w32_IsWin95)
1275{
1276 dXSARGS;
1277 EXTEND(SP,1);
1278 XSRETURN_IV(IsWin95());
1279}
1280
cf8b4e93
JD
1281XS(w32_FormatMessage)
1282{
1283 dXSARGS;
1284 DWORD source = 0;
1285 char msgbuf[ONE_K_BUFSIZE];
1286
1287 if (items != 1)
1288 Perl_croak(aTHX_ "usage: Win32::FormatMessage($errno)");
1289
1290 if (FormatMessageA(FORMAT_MESSAGE_FROM_SYSTEM,
b5701e9e 1291 &source, (DWORD)SvIV(ST(0)), 0,
cf8b4e93
JD
1292 msgbuf, sizeof(msgbuf)-1, NULL))
1293 {
1294 XSRETURN_PV(msgbuf);
1295 }
1296
1297 XSRETURN_UNDEF;
1298}
1299
cf8b4e93
JD
1300XS(w32_Spawn)
1301{
1302 dXSARGS;
1303 char *cmd, *args;
1304 void *env;
1305 char *dir;
1306 PROCESS_INFORMATION stProcInfo;
1307 STARTUPINFO stStartInfo;
1308 BOOL bSuccess = FALSE;
1309
1310 if (items != 3)
1311 Perl_croak(aTHX_ "usage: Win32::Spawn($cmdName, $args, $PID)");
1312
1313 cmd = SvPV_nolen(ST(0));
1314 args = SvPV_nolen(ST(1));
1315
1316 env = PerlEnv_get_childenv();
1317 dir = PerlEnv_get_childdir();
1318
1319 memset(&stStartInfo, 0, sizeof(stStartInfo)); /* Clear the block */
1320 stStartInfo.cb = sizeof(stStartInfo); /* Set the structure size */
1321 stStartInfo.dwFlags = STARTF_USESHOWWINDOW; /* Enable wShowWindow control */
1322 stStartInfo.wShowWindow = SW_SHOWMINNOACTIVE; /* Start min (normal) */
1323
1324 if (CreateProcess(
1325 cmd, /* Image path */
1326 args, /* Arguments for command line */
1327 NULL, /* Default process security */
1328 NULL, /* Default thread security */
1329 FALSE, /* Must be TRUE to use std handles */
1330 NORMAL_PRIORITY_CLASS, /* No special scheduling */
1331 env, /* Inherit our environment block */
1332 dir, /* Inherit our currrent directory */
1333 &stStartInfo, /* -> Startup info */
1334 &stProcInfo)) /* <- Process info (if OK) */
1335 {
1336 int pid = (int)stProcInfo.dwProcessId;
1337 if (IsWin95() && pid < 0)
1338 pid = -pid;
1339 sv_setiv(ST(2), pid);
1340 CloseHandle(stProcInfo.hThread);/* library source code does this. */
1341 bSuccess = TRUE;
1342 }
1343 PerlEnv_free_childenv(env);
1344 PerlEnv_free_childdir(dir);
1345 XSRETURN_IV(bSuccess);
1346}
1347
cf8b4e93
JD
1348XS(w32_GetTickCount)
1349{
1350 dXSARGS;
1351 DWORD msec = GetTickCount();
1352 EXTEND(SP,1);
1353 if ((IV)msec > 0)
1354 XSRETURN_IV(msec);
1355 XSRETURN_NV(msec);
1356}
1357
cf8b4e93
JD
1358XS(w32_GetShortPathName)
1359{
1360 dXSARGS;
1361 SV *shortpath;
1362 DWORD len;
1363
1364 if (items != 1)
1365 Perl_croak(aTHX_ "usage: Win32::GetShortPathName($longPathName)");
1366
34f7f30d
SH
1367 if (IsWin2000()) {
1368 WCHAR wshort[MAX_PATH+1];
1369 WCHAR *wlong = sv_to_wstr(aTHX_ ST(0));
1370 len = GetShortPathNameW(wlong, wshort, countof(wshort));
1371 Safefree(wlong);
b3eb56ab 1372 if (len && len < sizeof(wshort)) {
34f7f30d
SH
1373 ST(0) = wstr_to_sv(aTHX_ wshort);
1374 XSRETURN(1);
1375 }
1376 XSRETURN_UNDEF;
1377 }
1378
cf8b4e93
JD
1379 shortpath = sv_mortalcopy(ST(0));
1380 SvUPGRADE(shortpath, SVt_PV);
1381 if (!SvPVX(shortpath) || !SvLEN(shortpath))
1382 XSRETURN_UNDEF;
1383
1384 /* src == target is allowed */
1385 do {
1386 len = GetShortPathName(SvPVX(shortpath),
1387 SvPVX(shortpath),
b5701e9e 1388 (DWORD)SvLEN(shortpath));
cf8b4e93
JD
1389 } while (len >= SvLEN(shortpath) && sv_grow(shortpath,len+1));
1390 if (len) {
1391 SvCUR_set(shortpath,len);
1392 *SvEND(shortpath) = '\0';
1393 ST(0) = shortpath;
1394 XSRETURN(1);
1395 }
1396 XSRETURN_UNDEF;
1397}
1398
cf8b4e93
JD
1399XS(w32_GetFullPathName)
1400{
1401 dXSARGS;
34f7f30d
SH
1402 char *fullname;
1403 char *ansi = NULL;
1404
1405/* The code below relies on the fact that PerlDir_mapX() returns an
1406 * absolute path, which is only true under PERL_IMPLICIT_SYS when
1407 * we use the virtualization code from win32/vdir.h.
1408 * Without it PerlDir_mapX() is a no-op and we need to use the same
1409 * code as we use for Cygwin.
1410 */
1411#if __CYGWIN__ || !defined(PERL_IMPLICIT_SYS)
1412 char buffer[2*MAX_PATH];
1413#endif
cf8b4e93
JD
1414
1415 if (items != 1)
1416 Perl_croak(aTHX_ "usage: Win32::GetFullPathName($filename)");
1417
34f7f30d
SH
1418#if __CYGWIN__ || !defined(PERL_IMPLICIT_SYS)
1419 if (IsWin2000()) {
1420 WCHAR *filename = sv_to_wstr(aTHX_ ST(0));
1421 WCHAR full[2*MAX_PATH];
1422 DWORD len = GetFullPathNameW(filename, countof(full), full, NULL);
1423 Safefree(filename);
1424 if (len == 0 || len >= countof(full))
1425 XSRETURN_EMPTY;
1426 ansi = fullname = my_ansipath(full);
1427 }
1428 else {
1429 DWORD len = GetFullPathNameA(SvPV_nolen(ST(0)), countof(buffer), buffer, NULL);
1430 if (len == 0 || len >= countof(buffer))
1431 XSRETURN_EMPTY;
1432 fullname = buffer;
1433 }
1434#else
1435 /* Don't use my_ansipath() unless the $filename argument is in Unicode.
1436 * If the relative path doesn't exist, GetShortPathName() will fail and
1437 * my_ansipath() will use the long name with replacement characters.
1438 * In that case we will be better off using PerlDir_mapA(), which
1439 * already uses the ANSI name of the current directory.
1440 *
1441 * XXX The one missing case is where we could downgrade $filename
1442 * XXX from UTF8 into the current codepage.
1443 */
1444 if (IsWin2000() && SvUTF8(ST(0))) {
1445 WCHAR *filename = sv_to_wstr(aTHX_ ST(0));
1446 WCHAR *mappedname = PerlDir_mapW(filename);
1447 Safefree(filename);
1448 ansi = fullname = my_ansipath(mappedname);
1449 }
1450 else {
1451 fullname = PerlDir_mapA(SvPV_nolen(ST(0)));
1452 }
1453# if PERL_VERSION < 8
1454 {
1455 /* PerlDir_mapX() in Perl 5.6 used to return forward slashes */
1456 char *str = fullname;
1457 while (*str) {
1458 if (*str == '/')
1459 *str = '\\';
1460 ++str;
1461 }
1462 }
1463# endif
1464#endif
cf8b4e93 1465
34f7f30d
SH
1466 /* GetFullPathName() on Windows NT drops trailing backslash */
1467 if (g_osver.dwMajorVersion == 4 && *fullname) {
1468 STRLEN len;
1469 char *pv = SvPV(ST(0), len);
1470 char *lastchar = fullname + strlen(fullname) - 1;
1471 /* If ST(0) ends with a slash, but fullname doesn't ... */
1472 if (len && (pv[len-1] == '/' || pv[len-1] == '\\') && *lastchar != '\\') {
1473 /* fullname is the MAX_PATH+1 sized buffer returned from PerlDir_mapA()
1474 * or the 2*MAX_PATH sized local buffer in the __CYGWIN__ case.
1475 */
1476 strcpy(lastchar+1, "\\");
1477 }
cf8b4e93 1478 }
34f7f30d
SH
1479
1480 if (GIMME_V == G_ARRAY) {
1481 char *filepart = strrchr(fullname, '\\');
1482
1483 EXTEND(SP,1);
1484 if (filepart) {
1485 XST_mPV(1, ++filepart);
1486 *filepart = '\0';
1487 }
1488 else {
1489 XST_mPVN(1, "", 0);
1490 }
1491 items = 2;
1492 }
1493 XST_mPV(0, fullname);
1494
1495 if (ansi)
1496 Safefree(ansi);
1497 XSRETURN(items);
cf8b4e93
JD
1498}
1499
cf8b4e93
JD
1500XS(w32_GetLongPathName)
1501{
1502 dXSARGS;
cf8b4e93
JD
1503
1504 if (items != 1)
1505 Perl_croak(aTHX_ "usage: Win32::GetLongPathName($pathname)");
1506
34f7f30d
SH
1507 if (IsWin2000()) {
1508 WCHAR *wstr = sv_to_wstr(aTHX_ ST(0));
1509 WCHAR wide_path[MAX_PATH+1];
1510 WCHAR *long_path;
1511
1512 wcscpy(wide_path, wstr);
1513 Safefree(wstr);
1514 long_path = my_longpathW(wide_path);
1515 if (long_path) {
1516 ST(0) = wstr_to_sv(aTHX_ long_path);
1517 XSRETURN(1);
1518 }
1519 }
1520 else {
1521 SV *path;
1522 char tmpbuf[MAX_PATH+1];
1523 char *pathstr;
1524 STRLEN len;
1525
1526 path = ST(0);
1527 pathstr = SvPV(path,len);
1528 strcpy(tmpbuf, pathstr);
1529 pathstr = my_longpathA(tmpbuf);
1530 if (pathstr) {
1531 ST(0) = sv_2mortal(newSVpvn(pathstr, strlen(pathstr)));
1532 XSRETURN(1);
1533 }
cf8b4e93
JD
1534 }
1535 XSRETURN_EMPTY;
1536}
1537
34f7f30d
SH
1538XS(w32_GetANSIPathName)
1539{
1540 dXSARGS;
1541 WCHAR *wide_path;
1542
1543 if (items != 1)
1544 Perl_croak(aTHX_ "usage: Win32::GetANSIPathName($pathname)");
1545
1546 wide_path = sv_to_wstr(aTHX_ ST(0));
1547 ST(0) = wstr_to_ansipath(aTHX_ wide_path);
1548 Safefree(wide_path);
1549 XSRETURN(1);
1550}
1551
cf8b4e93
JD
1552XS(w32_Sleep)
1553{
1554 dXSARGS;
1555 if (items != 1)
1556 Perl_croak(aTHX_ "usage: Win32::Sleep($milliseconds)");
b5701e9e 1557 Sleep((DWORD)SvIV(ST(0)));
cf8b4e93
JD
1558 XSRETURN_YES;
1559}
1560
cf8b4e93
JD
1561XS(w32_CopyFile)
1562{
1563 dXSARGS;
1564 BOOL bResult;
1565 char szSourceFile[MAX_PATH+1];
1566
1567 if (items != 3)
1568 Perl_croak(aTHX_ "usage: Win32::CopyFile($from, $to, $overwrite)");
1569 strcpy(szSourceFile, PerlDir_mapA(SvPV_nolen(ST(0))));
1570 bResult = CopyFileA(szSourceFile, PerlDir_mapA(SvPV_nolen(ST(1))), !SvTRUE(ST(2)));
1571 if (bResult)
1572 XSRETURN_YES;
1573 XSRETURN_NO;
1574}
1575
34f7f30d
SH
1576XS(w32_OutputDebugString)
1577{
1578 dXSARGS;
1579 if (items != 1)
1580 Perl_croak(aTHX_ "usage: Win32::OutputDebugString($string)");
1581
1582 if (SvUTF8(ST(0))) {
1583 WCHAR *str = sv_to_wstr(aTHX_ ST(0));
1584 OutputDebugStringW(str);
1585 Safefree(str);
1586 }
1587 else
1588 OutputDebugStringA(SvPV_nolen(ST(0)));
1589
1590 XSRETURN_EMPTY;
1591}
1592
280cf07e
SH
1593XS(w32_GetCurrentProcessId)
1594{
1595 dXSARGS;
1596 EXTEND(SP,1);
1597 XSRETURN_IV(GetCurrentProcessId());
1598}
1599
34f7f30d
SH
1600XS(w32_GetCurrentThreadId)
1601{
1602 dXSARGS;
1603 EXTEND(SP,1);
1604 XSRETURN_IV(GetCurrentThreadId());
1605}
1606
1607XS(w32_CreateDirectory)
1608{
1609 dXSARGS;
1610 BOOL result;
1611
1612 if (items != 1)
1613 Perl_croak(aTHX_ "usage: Win32::CreateDirectory($dir)");
1614
1615 if (IsWin2000() && SvUTF8(ST(0))) {
1616 WCHAR *dir = sv_to_wstr(aTHX_ ST(0));
1617 result = CreateDirectoryW(dir, NULL);
1618 Safefree(dir);
1619 }
1620 else {
1621 result = CreateDirectoryA(SvPV_nolen(ST(0)), NULL);
1622 }
1623
1624 ST(0) = boolSV(result);
1625 XSRETURN(1);
1626}
1627
1628XS(w32_CreateFile)
b4ad57f4
NC
1629{
1630 dXSARGS;
34f7f30d
SH
1631 HANDLE handle;
1632
1633 if (items != 1)
1634 Perl_croak(aTHX_ "usage: Win32::CreateFile($file)");
1635
1636 if (IsWin2000() && SvUTF8(ST(0))) {
1637 WCHAR *file = sv_to_wstr(aTHX_ ST(0));
1638 handle = CreateFileW(file, GENERIC_WRITE, FILE_SHARE_WRITE,
1639 NULL, CREATE_NEW, FILE_ATTRIBUTE_NORMAL, NULL);
1640 Safefree(file);
1641 }
1642 else {
1643 handle = CreateFileA(SvPV_nolen(ST(0)), GENERIC_WRITE, FILE_SHARE_WRITE,
1644 NULL, CREATE_NEW, FILE_ATTRIBUTE_NORMAL, NULL);
1645 }
1646
1647 if (handle != INVALID_HANDLE_VALUE)
1648 CloseHandle(handle);
1649
1650 ST(0) = boolSV(handle != INVALID_HANDLE_VALUE);
1651 XSRETURN(1);
1652}
1653
1654MODULE = Win32 PACKAGE = Win32
1655
1656PROTOTYPES: DISABLE
1657
1658BOOT:
1659{
b4ad57f4
NC
1660 char *file = __FILE__;
1661
cf8b4e93
JD
1662 if (g_osver.dwOSVersionInfoSize == 0) {
1663 g_osver.dwOSVersionInfoSize = sizeof(g_osver);
34f7f30d
SH
1664 if (!GetVersionExA((OSVERSIONINFOA*)&g_osver)) {
1665 g_osver_ex = FALSE;
1666 g_osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFOA);
1667 GetVersionExA((OSVERSIONINFOA*)&g_osver);
1668 }
cf8b4e93
JD
1669 }
1670
b4ad57f4
NC
1671 newXS("Win32::LookupAccountName", w32_LookupAccountName, file);
1672 newXS("Win32::LookupAccountSID", w32_LookupAccountSID, file);
1673 newXS("Win32::InitiateSystemShutdown", w32_InitiateSystemShutdown, file);
1674 newXS("Win32::AbortSystemShutdown", w32_AbortSystemShutdown, file);
1675 newXS("Win32::ExpandEnvironmentStrings", w32_ExpandEnvironmentStrings, file);
1676 newXS("Win32::MsgBox", w32_MsgBox, file);
1677 newXS("Win32::LoadLibrary", w32_LoadLibrary, file);
1678 newXS("Win32::FreeLibrary", w32_FreeLibrary, file);
1679 newXS("Win32::GetProcAddress", w32_GetProcAddress, file);
1680 newXS("Win32::RegisterServer", w32_RegisterServer, file);
1681 newXS("Win32::UnregisterServer", w32_UnregisterServer, file);
1682 newXS("Win32::GetArchName", w32_GetArchName, file);
1683 newXS("Win32::GetChipName", w32_GetChipName, file);
1684 newXS("Win32::GuidGen", w32_GuidGen, file);
1685 newXS("Win32::GetFolderPath", w32_GetFolderPath, file);
1686 newXS("Win32::IsAdminUser", w32_IsAdminUser, file);
e364e11c 1687 newXS("Win32::GetFileVersion", w32_GetFileVersion, file);
b4ad57f4 1688
cf8b4e93
JD
1689 newXS("Win32::GetCwd", w32_GetCwd, file);
1690 newXS("Win32::SetCwd", w32_SetCwd, file);
1691 newXS("Win32::GetNextAvailDrive", w32_GetNextAvailDrive, file);
1692 newXS("Win32::GetLastError", w32_GetLastError, file);
1693 newXS("Win32::SetLastError", w32_SetLastError, file);
1694 newXS("Win32::LoginName", w32_LoginName, file);
1695 newXS("Win32::NodeName", w32_NodeName, file);
1696 newXS("Win32::DomainName", w32_DomainName, file);
1697 newXS("Win32::FsType", w32_FsType, file);
1698 newXS("Win32::GetOSVersion", w32_GetOSVersion, file);
1699 newXS("Win32::IsWinNT", w32_IsWinNT, file);
1700 newXS("Win32::IsWin95", w32_IsWin95, file);
1701 newXS("Win32::FormatMessage", w32_FormatMessage, file);
1702 newXS("Win32::Spawn", w32_Spawn, file);
1703 newXS("Win32::GetTickCount", w32_GetTickCount, file);
1704 newXS("Win32::GetShortPathName", w32_GetShortPathName, file);
1705 newXS("Win32::GetFullPathName", w32_GetFullPathName, file);
1706 newXS("Win32::GetLongPathName", w32_GetLongPathName, file);
34f7f30d 1707 newXS("Win32::GetANSIPathName", w32_GetANSIPathName, file);
cf8b4e93
JD
1708 newXS("Win32::CopyFile", w32_CopyFile, file);
1709 newXS("Win32::Sleep", w32_Sleep, file);
34f7f30d 1710 newXS("Win32::OutputDebugString", w32_OutputDebugString, file);
280cf07e 1711 newXS("Win32::GetCurrentProcessId", w32_GetCurrentProcessId, file);
34f7f30d
SH
1712 newXS("Win32::GetCurrentThreadId", w32_GetCurrentThreadId, file);
1713 newXS("Win32::CreateDirectory", w32_CreateDirectory, file);
1714 newXS("Win32::CreateFile", w32_CreateFile, file);
5bd7e777 1715#ifdef __CYGWIN__
cf8b4e93 1716 newXS("Win32::SetChildShowWindow", w32_SetChildShowWindow, file);
5bd7e777 1717#endif
b4ad57f4
NC
1718 XSRETURN_YES;
1719}