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