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