5 #define PERL_NO_GET_CONTEXT
11 # define countof(array) (sizeof (array) / sizeof (*(array)))
14 #define SE_SHUTDOWN_NAMEA "SeShutdownPrivilege"
16 #ifndef WC_NO_BEST_FIT_CHARS
17 # define WC_NO_BEST_FIT_CHARS 0x00000400
20 #define GETPROC(fn) pfn##fn = (PFN##fn)GetProcAddress(module, #fn)
22 typedef BOOL (WINAPI *PFNSHGetSpecialFolderPathA)(HWND, char*, int, BOOL);
23 typedef BOOL (WINAPI *PFNSHGetSpecialFolderPathW)(HWND, WCHAR*, int, BOOL);
24 typedef HRESULT (WINAPI *PFNSHGetFolderPathA)(HWND, int, HANDLE, DWORD, LPTSTR);
25 typedef HRESULT (WINAPI *PFNSHGetFolderPathW)(HWND, int, HANDLE, DWORD, LPWSTR);
26 typedef BOOL (WINAPI *PFNCreateEnvironmentBlock)(void**, HANDLE, BOOL);
27 typedef BOOL (WINAPI *PFNDestroyEnvironmentBlock)(void*);
28 typedef int (__stdcall *PFNDllRegisterServer)(void);
29 typedef int (__stdcall *PFNDllUnregisterServer)(void);
30 typedef DWORD (__stdcall *PFNNetApiBufferFree)(void*);
31 typedef DWORD (__stdcall *PFNNetWkstaGetInfo)(LPWSTR, DWORD, void*);
33 typedef BOOL (__stdcall *PFNOpenProcessToken)(HANDLE, DWORD, HANDLE*);
34 typedef BOOL (__stdcall *PFNOpenThreadToken)(HANDLE, DWORD, BOOL, HANDLE*);
35 typedef BOOL (__stdcall *PFNGetTokenInformation)(HANDLE, TOKEN_INFORMATION_CLASS, void*, DWORD, DWORD*);
36 typedef BOOL (__stdcall *PFNAllocateAndInitializeSid)(PSID_IDENTIFIER_AUTHORITY, BYTE, DWORD, DWORD,
37 DWORD, DWORD, DWORD, DWORD, DWORD, DWORD, PSID*);
38 typedef BOOL (__stdcall *PFNEqualSid)(PSID, PSID);
39 typedef void* (__stdcall *PFNFreeSid)(PSID);
40 typedef BOOL (__stdcall *PFNIsUserAnAdmin)();
42 #ifndef CSIDL_FLAG_CREATE
43 # define CSIDL_FLAG_CREATE 0x8000
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
60 #ifndef CSIDL_CDBURN_AREA
61 # define CSIDL_CDBURN_AREA 0x003B
64 #ifndef CSIDL_COMMON_MUSIC
65 # define CSIDL_COMMON_MUSIC 0x0035
68 #ifndef CSIDL_COMMON_PICTURES
69 # define CSIDL_COMMON_PICTURES 0x0036
72 #ifndef CSIDL_COMMON_VIDEO
73 # define CSIDL_COMMON_VIDEO 0x0037
77 # define CSIDL_MYMUSIC 0x000D
81 # define CSIDL_MYVIDEO 0x000E
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.
90 DWORD dwOSVersionInfoSize;
95 CHAR szCSDVersion[128];
96 unsigned short wServicePackMajor;
97 unsigned short wServicePackMinor;
98 unsigned short wSuiteMask;
101 } g_osver = {0, 0, 0, 0, 0, "", 0, 0, 0, 0, 0};
102 BOOL g_osver_ex = TRUE;
104 #define ONE_K_BUFSIZE 1024
109 return (g_osver.dwPlatformId == VER_PLATFORM_WIN32_WINDOWS);
115 return (g_osver.dwPlatformId == VER_PLATFORM_WIN32_NT);
121 return (g_osver.dwMajorVersion > 4);
124 /* Convert SV to wide character string. The return value must be
125 * freed using Safefree().
128 sv_to_wstr(pTHX_ SV *sv)
133 char *str = SvPV(sv, len);
134 UINT cp = SvUTF8(sv) ? CP_UTF8 : CP_ACP;
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);
143 /* Convert wide character string to mortal SV. Use UTF8 encoding
144 * if the string cannot be represented in the system codepage.
147 wstr_to_sv(pTHX_ WCHAR *wstr)
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));
154 len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, wstr, wlen, SvPVX(sv), len, NULL, &use_default);
156 len = WideCharToMultiByte(CP_UTF8, 0, wstr, wlen, NULL, 0, NULL, NULL);
158 len = WideCharToMultiByte(CP_UTF8, 0, wstr, wlen, SvPVX(sv), len, NULL, NULL);
161 /* Shouldn't really ever fail since we ask for the required length first, but who knows... */
164 SvCUR_set(sv, len-1);
169 /* Retrieve a variable from the Unicode environment in a mortal SV.
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.
176 get_unicode_env(pTHX_ WCHAR *name)
182 PFNOpenProcessToken pfnOpenProcessToken;
184 /* Get security token for the current process owner */
185 module = LoadLibrary("advapi32.dll");
189 GETPROC(OpenProcessToken);
191 if (pfnOpenProcessToken == NULL ||
192 !pfnOpenProcessToken(GetCurrentProcess(), TOKEN_QUERY | TOKEN_DUPLICATE, &token))
199 /* Create a Unicode environment block for this process */
200 module = LoadLibrary("userenv.dll");
202 PFNCreateEnvironmentBlock pfnCreateEnvironmentBlock;
203 PFNDestroyEnvironmentBlock pfnDestroyEnvironmentBlock;
205 GETPROC(CreateEnvironmentBlock);
206 GETPROC(DestroyEnvironmentBlock);
208 if (pfnCreateEnvironmentBlock && pfnDestroyEnvironmentBlock &&
209 pfnCreateEnvironmentBlock(&env, token, FALSE))
211 size_t name_len = wcslen(name);
215 size_t entry_len = wcslen(entry);
216 BOOL equal = (entry_len > name_len) && (entry[name_len] == '=');
218 for (i=0; equal && i < name_len; ++i)
219 equal = (towupper(entry[i]) == towupper(name[i]));
222 sv = wstr_to_sv(aTHX_ entry+name_len+1);
225 entry += entry_len+1;
227 pfnDestroyEnvironmentBlock(env);
235 /* Define both an ANSI and a Wide version of win32_longpath */
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"
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"
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.
257 * The buffer to the ansi pathname must be freed with Safefree() when it
258 * it no longer needed.
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.
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!
271 /* This is a modified version of core Perl win32/win32.c(win32_ansipath).
272 * It uses New() etc. instead of win32_malloc().
276 my_ansipath(const WCHAR *widename)
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);
287 DWORD shortlen = GetShortPathNameW(widename, NULL, 0);
290 New(0, shortname, shortlen, WCHAR);
291 shortlen = GetShortPathNameW(widename, shortname, shortlen)+1;
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);
304 /* Convert wide character path to ANSI path and return as mortal SV. */
306 wstr_to_ansipath(pTHX_ WCHAR *wstr)
308 char *ansi = my_ansipath(wstr);
309 SV *sv = sv_2mortal(newSVpvn(ansi, strlen(ansi)));
323 WCHAR filename[MAX_PATH+1];
324 GetCurrentDirectoryW(MAX_PATH+1, filename);
325 ptr = my_ansipath(filename);
328 char filename[MAX_PATH+1];
329 GetCurrentDirectoryA(MAX_PATH+1, filename);
330 New(0, ptr, strlen(filename)+1, char);
331 strcpy(ptr, filename);
337 free_childdir(char *d)
350 free_childenv(void *d)
354 # define PerlDir_mapA(dir) (dir)
358 XS(w32_ExpandEnvironmentStrings)
363 croak("usage: Win32::ExpandEnvironmentStrings($String);\n");
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);
375 ExpandEnvironmentStringsA(SvPV_nolen(ST(0)), value, countof(value)-2);
384 PFNIsUserAnAdmin pfnIsUserAnAdmin;
385 PFNOpenThreadToken pfnOpenThreadToken;
386 PFNOpenProcessToken pfnOpenProcessToken;
387 PFNGetTokenInformation pfnGetTokenInformation;
388 PFNAllocateAndInitializeSid pfnAllocateAndInitializeSid;
389 PFNEqualSid pfnEqualSid;
390 PFNFreeSid pfnFreeSid;
393 TOKEN_GROUPS *lpTokInfo;
394 SID_IDENTIFIER_AUTHORITY NtAuth = SECURITY_NT_AUTHORITY;
400 croak("usage: Win32::IsAdminUser()");
402 /* There is no concept of "Administrator" user accounts on Win9x systems,
403 so just return true. */
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.
411 module = LoadLibrary("shell32.dll");
413 GETPROC(IsUserAnAdmin);
414 if (pfnIsUserAnAdmin) {
416 ST(0) = sv_2mortal(newSViv(pfnIsUserAnAdmin() ? 1 : 0));
423 module = LoadLibrary("advapi32.dll");
425 warn("Cannot load advapi32.dll library");
429 GETPROC(OpenThreadToken);
430 GETPROC(OpenProcessToken);
431 GETPROC(GetTokenInformation);
432 GETPROC(AllocateAndInitializeSid);
436 if (!(pfnOpenThreadToken && pfnOpenProcessToken &&
437 pfnGetTokenInformation && pfnAllocateAndInitializeSid &&
438 pfnEqualSid && pfnFreeSid))
440 warn("Cannot load functions from advapi32.dll library");
445 if (!pfnOpenThreadToken(GetCurrentThread(), TOKEN_QUERY, FALSE, &hTok)) {
446 if (!pfnOpenProcessToken(GetCurrentProcess(), TOKEN_QUERY, &hTok)) {
447 warn("Cannot open thread token or process token");
453 pfnGetTokenInformation(hTok, TokenGroups, NULL, 0, &dwTokInfoLen);
454 if (!New(1, lpTokInfo, dwTokInfoLen, TOKEN_GROUPS)) {
455 warn("Cannot allocate token information structure");
461 if (!pfnGetTokenInformation(hTok, TokenGroups, lpTokInfo, dwTokInfoLen,
464 warn("Cannot get token information");
471 if (!pfnAllocateAndInitializeSid(&NtAuth, 2, SECURITY_BUILTIN_DOMAIN_RID,
472 DOMAIN_ALIAS_RID_ADMINS, 0, 0, 0, 0, 0, 0, &pAdminSid))
474 warn("Cannot allocate administrators' SID");
482 for (i = 0; i < lpTokInfo->GroupCount; ++i) {
483 if (pfnEqualSid(lpTokInfo->Groups[i].Sid, pAdminSid)) {
489 pfnFreeSid(pAdminSid);
495 ST(0) = sv_2mortal(newSViv(iRetVal));
499 XS(w32_LookupAccountName)
510 croak("usage: Win32::LookupAccountName($system, $account, $domain, "
511 "$sid, $sidtype);\n");
513 SIDLen = sizeof(SID);
514 DomLen = sizeof(Domain);
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 */
524 sv_setpv(ST(2), Domain);
525 sv_setpvn(ST(3), SID, SIDLen);
526 sv_setiv(ST(4), snu);
533 XS(w32_LookupAccountSID)
538 DWORD AcctLen = sizeof(Account);
540 DWORD DomLen = sizeof(Domain);
545 croak("usage: Win32::LookupAccountSID($system, $sid, $account, $domain, $sidtype);\n");
547 sid = SvPV_nolen(ST(1));
548 if (IsValidSid(sid)) {
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 */
557 sv_setpv(ST(2), Account);
558 sv_setpv(ST(3), Domain);
559 sv_setiv(ST(4), (IV)snu);
566 XS(w32_InitiateSystemShutdown)
569 HANDLE hToken; /* handle to process token */
570 TOKEN_PRIVILEGES tkp; /* pointer to token structure */
572 char *machineName, *message;
575 croak("usage: Win32::InitiateSystemShutdown($machineName, $message, "
576 "$timeOut, $forceClose, $reboot);\n");
578 machineName = SvPV_nolen(ST(0));
580 if (OpenProcessToken(GetCurrentProcess(),
581 TOKEN_ADJUST_PRIVILEGES | TOKEN_QUERY,
584 LookupPrivilegeValueA(machineName,
586 &tkp.Privileges[0].Luid);
588 tkp.PrivilegeCount = 1; /* only setting one */
589 tkp.Privileges[0].Attributes = SE_PRIVILEGE_ENABLED;
591 /* Get shutdown privilege for this process. */
592 AdjustTokenPrivileges(hToken, FALSE, &tkp, 0,
593 (PTOKEN_PRIVILEGES)NULL, 0);
596 message = SvPV_nolen(ST(1));
597 bRet = InitiateSystemShutdownA(machineName, message,
598 SvIV(ST(2)), SvIV(ST(3)), SvIV(ST(4)));
600 /* Disable shutdown privilege. */
601 tkp.Privileges[0].Attributes = 0;
602 AdjustTokenPrivileges(hToken, FALSE, &tkp, 0,
603 (PTOKEN_PRIVILEGES)NULL, 0);
608 XS(w32_AbortSystemShutdown)
611 HANDLE hToken; /* handle to process token */
612 TOKEN_PRIVILEGES tkp; /* pointer to token structure */
617 croak("usage: Win32::AbortSystemShutdown($machineName);\n");
619 machineName = SvPV_nolen(ST(0));
621 if (OpenProcessToken(GetCurrentProcess(),
622 TOKEN_ADJUST_PRIVILEGES | TOKEN_QUERY,
625 LookupPrivilegeValueA(machineName,
627 &tkp.Privileges[0].Luid);
629 tkp.PrivilegeCount = 1; /* only setting one */
630 tkp.Privileges[0].Attributes = SE_PRIVILEGE_ENABLED;
632 /* Get shutdown privilege for this process. */
633 AdjustTokenPrivileges(hToken, FALSE, &tkp, 0,
634 (PTOKEN_PRIVILEGES)NULL, 0);
637 bRet = AbortSystemShutdownA(machineName);
639 /* Disable shutdown privilege. */
640 tkp.Privileges[0].Attributes = 0;
641 AdjustTokenPrivileges(hToken, FALSE, &tkp, 0,
642 (PTOKEN_PRIVILEGES)NULL, 0);
651 DWORD flags = MB_ICONEXCLAMATION;
654 if (items < 1 || items > 3)
655 croak("usage: Win32::MsgBox($message [, $flags [, $title]]);\n");
662 WCHAR *msg = sv_to_wstr(aTHX_ ST(0));
664 title = sv_to_wstr(aTHX_ ST(2));
665 result = MessageBoxW(GetActiveWindow(), msg, title ? title : L"Perl", flags);
671 char *title = "Perl";
672 char *msg = SvPV_nolen(ST(0));
674 title = SvPV_nolen(ST(2));
675 result = MessageBoxA(GetActiveWindow(), msg, title, flags);
686 croak("usage: Win32::LoadLibrary($libname)\n");
687 hHandle = LoadLibraryA(SvPV_nolen(ST(0)));
688 XSRETURN_IV((long)hHandle);
696 croak("usage: Win32::FreeLibrary($handle)\n");
697 if (FreeLibrary(INT2PTR(HINSTANCE, SvIV(ST(0))))) {
703 XS(w32_GetProcAddress)
708 croak("usage: Win32::GetProcAddress($hinstance, $procname)\n");
709 XSRETURN_IV(PTR2IV(GetProcAddress(INT2PTR(HINSTANCE, SvIV(ST(0))), SvPV_nolen(ST(1)))));
712 XS(w32_RegisterServer)
719 croak("usage: Win32::RegisterServer($libname)\n");
721 module = LoadLibraryA(SvPV_nolen(ST(0)));
723 PFNDllRegisterServer pfnDllRegisterServer;
724 GETPROC(DllRegisterServer);
725 if (pfnDllRegisterServer && pfnDllRegisterServer() == 0)
729 ST(0) = boolSV(result);
733 XS(w32_UnregisterServer)
740 croak("usage: Win32::UnregisterServer($libname)\n");
742 module = LoadLibraryA(SvPV_nolen(ST(0)));
744 PFNDllUnregisterServer pfnDllUnregisterServer;
745 GETPROC(DllUnregisterServer);
746 if (pfnDllUnregisterServer && pfnDllUnregisterServer() == 0)
750 ST(0) = boolSV(result);
754 /* XXX rather bogus */
758 XSRETURN_PV(getenv("PROCESSOR_ARCHITECTURE"));
766 Zero(&sysinfo,1,SYSTEM_INFO);
767 GetSystemInfo(&sysinfo);
768 /* XXX docs say dwProcessorType is deprecated on NT */
769 XSRETURN_IV(sysinfo.dwProcessorType);
776 char szGUID[50] = {'\0'};
777 HRESULT hr = CoCreateGuid(&guid);
780 LPOLESTR pStr = NULL;
781 if (SUCCEEDED(StringFromCLSID(&guid, &pStr))) {
782 WideCharToMultiByte(CP_ACP, 0, pStr, wcslen(pStr), szGUID,
783 sizeof(szGUID), NULL, NULL);
791 XS(w32_GetFolderPath)
794 char path[MAX_PATH+1];
795 WCHAR wpath[MAX_PATH+1];
800 if (items != 1 && items != 2)
801 croak("usage: Win32::GetFolderPath($csidl [, $create])\n");
803 folder = SvIV(ST(0));
805 create = SvTRUE(ST(1)) ? CSIDL_FLAG_CREATE : 0;
807 module = LoadLibrary("shfolder.dll");
809 PFNSHGetFolderPathA pfna;
811 PFNSHGetFolderPathW pfnw;
812 pfnw = (PFNSHGetFolderPathW)GetProcAddress(module, "SHGetFolderPathW");
813 if (pfnw && SUCCEEDED(pfnw(NULL, folder|create, NULL, 0, wpath))) {
815 ST(0) = wstr_to_ansipath(aTHX_ wpath);
819 pfna = (PFNSHGetFolderPathA)GetProcAddress(module, "SHGetFolderPathA");
820 if (pfna && SUCCEEDED(pfna(NULL, folder|create, NULL, 0, path))) {
827 module = LoadLibrary("shell32.dll");
829 PFNSHGetSpecialFolderPathA pfna;
831 PFNSHGetSpecialFolderPathW pfnw;
832 pfnw = (PFNSHGetSpecialFolderPathW)GetProcAddress(module, "SHGetSpecialFolderPathW");
833 if (pfnw && pfnw(NULL, wpath, folder, !!create)) {
835 ST(0) = wstr_to_ansipath(aTHX_ wpath);
839 pfna = (PFNSHGetSpecialFolderPathA)GetProcAddress(module, "SHGetSpecialFolderPathA");
840 if (pfna && pfna(NULL, path, folder, !!create)) {
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...
854 HKEY root = HKEY_CURRENT_USER;
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;
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" */
885 root = HKEY_LOCAL_MACHINE;
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;
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.
907 #define SHELL_FOLDERS "Software\\Microsoft\\Windows\\CurrentVersion\\Explorer\\Shell Folders"
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);
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);
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.
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;
947 XS(w32_GetFileVersion)
956 croak("usage: Win32::GetFileVersion($filename)\n");
958 filename = SvPV_nolen(ST(0));
959 size = GetFileVersionInfoSize(filename, &handle);
963 New(0, data, size, char);
967 if (GetFileVersionInfo(filename, handle, size, data)) {
968 VS_FIXEDFILEINFO *info;
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);
976 if (GIMME_V == G_ARRAY) {
978 XST_mIV(0, dwValueMS1);
979 XST_mIV(1, dwValueMS2);
980 XST_mIV(2, dwValueLS1);
981 XST_mIV(3, dwValueLS2);
986 sprintf(version, "%d.%d.%d.%d", dwValueMS1, dwValueMS2, dwValueLS1, dwValueLS2);
999 XS(w32_SetChildShowWindow)
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.
1015 /* Make the host for current directory */
1016 char* ptr = PerlEnv_get_childdir();
1019 * then it worked, set PV valid,
1020 * else return 'undef'
1023 SV *sv = sv_newmortal();
1025 PerlEnv_free_childdir(ptr);
1027 #ifndef INCOMPLETE_TAINTS
1042 Perl_croak(aTHX_ "usage: Win32::SetCwd($cwd)");
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);
1054 if (!PerlDir_chdir(SvPV_nolen(ST(0))))
1061 XS(w32_GetNextAvailDrive)
1065 char root[] = "_:\\";
1070 if (GetDriveType(root) == 1) {
1078 XS(w32_GetLastError)
1082 XSRETURN_IV(GetLastError());
1085 XS(w32_SetLastError)
1089 Perl_croak(aTHX_ "usage: Win32::SetLastError($error)");
1090 SetLastError(SvIV(ST(0)));
1100 DWORD size = countof(name);
1101 if (GetUserNameW(name, &size)) {
1102 ST(0) = wstr_to_sv(aTHX_ name);
1108 DWORD size = countof(name);
1109 if (GetUserNameA(name, &size)) {
1110 /* size includes NULL */
1111 ST(0) = sv_2mortal(newSVpvn(name, size-1));
1121 char name[MAX_COMPUTERNAME_LENGTH+1];
1122 DWORD size = sizeof(name);
1124 if (GetComputerName(name,&size)) {
1125 /* size does NOT include NULL :-( */
1126 ST(0) = sv_2mortal(newSVpvn(name,size));
1136 HMODULE module = LoadLibrary("netapi32.dll");
1137 PFNNetApiBufferFree pfnNetApiBufferFree;
1138 PFNNetWkstaGetInfo pfnNetWkstaGetInfo;
1141 GETPROC(NetApiBufferFree);
1142 GETPROC(NetWkstaGetInfo);
1145 if (module && pfnNetWkstaGetInfo && pfnNetApiBufferFree) {
1146 /* this way is more reliable, in case user has a local account. */
1148 DWORD dnamelen = sizeof(dname);
1150 DWORD wki100_platform_id;
1151 LPWSTR wki100_computername;
1152 LPWSTR wki100_langroup;
1153 DWORD wki100_ver_major;
1154 DWORD wki100_ver_minor;
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);
1163 WideCharToMultiByte(CP_ACP, 0, pwi->wki100_computername,
1164 -1, (LPSTR)dname, dnamelen, NULL, NULL);
1166 pfnNetApiBufferFree(pwi);
1167 FreeLibrary(module);
1170 FreeLibrary(module);
1173 /* Win95 doesn't have NetWksta*(), so do it the old way */
1175 DWORD size = sizeof(name);
1177 FreeLibrary(module);
1178 if (GetUserName(name,&size)) {
1179 char sid[ONE_K_BUFSIZE];
1180 DWORD sidlen = sizeof(sid);
1182 DWORD dnamelen = sizeof(dname);
1184 if (LookupAccountName(NULL, name, (PSID)&sid, &sidlen,
1185 dname, &dnamelen, &snu)) {
1186 XSRETURN_PV(dname); /* all that for this */
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)));
1208 XSRETURN_PV(fsname);
1213 XS(w32_GetOSVersion)
1217 if (GIMME_V == G_SCALAR) {
1218 XSRETURN_IV(g_osver.dwPlatformId);
1220 XPUSHs(newSVpvn(g_osver.szCSDVersion, strlen(g_osver.szCSDVersion)));
1222 XPUSHs(newSViv(g_osver.dwMajorVersion));
1223 XPUSHs(newSViv(g_osver.dwMinorVersion));
1224 XPUSHs(newSViv(g_osver.dwBuildNumber));
1225 XPUSHs(newSViv(g_osver.dwPlatformId));
1227 XPUSHs(newSViv(g_osver.wServicePackMajor));
1228 XPUSHs(newSViv(g_osver.wServicePackMinor));
1229 XPUSHs(newSViv(g_osver.wSuiteMask));
1230 XPUSHs(newSViv(g_osver.wProductType));
1239 XSRETURN_IV(IsWinNT());
1246 XSRETURN_IV(IsWin95());
1249 XS(w32_FormatMessage)
1253 char msgbuf[ONE_K_BUFSIZE];
1256 Perl_croak(aTHX_ "usage: Win32::FormatMessage($errno)");
1258 if (FormatMessageA(FORMAT_MESSAGE_FROM_SYSTEM,
1259 &source, SvIV(ST(0)), 0,
1260 msgbuf, sizeof(msgbuf)-1, NULL))
1262 XSRETURN_PV(msgbuf);
1274 PROCESS_INFORMATION stProcInfo;
1275 STARTUPINFO stStartInfo;
1276 BOOL bSuccess = FALSE;
1279 Perl_croak(aTHX_ "usage: Win32::Spawn($cmdName, $args, $PID)");
1281 cmd = SvPV_nolen(ST(0));
1282 args = SvPV_nolen(ST(1));
1284 env = PerlEnv_get_childenv();
1285 dir = PerlEnv_get_childdir();
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) */
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) */
1304 int pid = (int)stProcInfo.dwProcessId;
1305 if (IsWin95() && pid < 0)
1307 sv_setiv(ST(2), pid);
1308 CloseHandle(stProcInfo.hThread);/* library source code does this. */
1311 PerlEnv_free_childenv(env);
1312 PerlEnv_free_childdir(dir);
1313 XSRETURN_IV(bSuccess);
1316 XS(w32_GetTickCount)
1319 DWORD msec = GetTickCount();
1326 XS(w32_GetShortPathName)
1333 Perl_croak(aTHX_ "usage: Win32::GetShortPathName($longPathName)");
1336 WCHAR wshort[MAX_PATH+1];
1337 WCHAR *wlong = sv_to_wstr(aTHX_ ST(0));
1338 len = GetShortPathNameW(wlong, wshort, countof(wshort));
1340 if (len < sizeof(wshort)) {
1341 ST(0) = wstr_to_sv(aTHX_ wshort);
1347 shortpath = sv_mortalcopy(ST(0));
1348 SvUPGRADE(shortpath, SVt_PV);
1349 if (!SvPVX(shortpath) || !SvLEN(shortpath))
1352 /* src == target is allowed */
1354 len = GetShortPathName(SvPVX(shortpath),
1357 } while (len >= SvLEN(shortpath) && sv_grow(shortpath,len+1));
1359 SvCUR_set(shortpath,len);
1360 *SvEND(shortpath) = '\0';
1367 XS(w32_GetFullPathName)
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.
1379 #if __CYGWIN__ || !defined(PERL_IMPLICIT_SYS)
1380 char buffer[2*MAX_PATH];
1384 Perl_croak(aTHX_ "usage: Win32::GetFullPathName($filename)");
1386 #if __CYGWIN__ || !defined(PERL_IMPLICIT_SYS)
1388 WCHAR *filename = sv_to_wstr(aTHX_ ST(0));
1389 WCHAR full[2*MAX_PATH];
1390 DWORD len = GetFullPathNameW(filename, countof(full), full, NULL);
1392 if (len == 0 || len >= countof(full))
1394 ansi = fullname = my_ansipath(full);
1397 DWORD len = GetFullPathNameA(SvPV_nolen(ST(0)), countof(buffer), buffer, NULL);
1398 if (len == 0 || len >= countof(buffer))
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.
1409 * XXX The one missing case is where we could downgrade $filename
1410 * XXX from UTF8 into the current codepage.
1412 if (IsWin2000() && SvUTF8(ST(0))) {
1413 WCHAR *filename = sv_to_wstr(aTHX_ ST(0));
1414 WCHAR *mappedname = PerlDir_mapW(filename);
1416 ansi = fullname = my_ansipath(mappedname);
1419 fullname = PerlDir_mapA(SvPV_nolen(ST(0)));
1421 # if PERL_VERSION < 8
1423 /* PerlDir_mapX() in Perl 5.6 used to return forward slashes */
1424 char *str = fullname;
1434 /* GetFullPathName() on Windows NT drops trailing backslash */
1435 if (g_osver.dwMajorVersion == 4 && *fullname) {
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.
1444 strcpy(lastchar+1, "\\");
1448 if (GIMME_V == G_ARRAY) {
1449 char *filepart = strrchr(fullname, '\\');
1453 XST_mPV(1, ++filepart);
1461 XST_mPV(0, fullname);
1468 XS(w32_GetLongPathName)
1473 Perl_croak(aTHX_ "usage: Win32::GetLongPathName($pathname)");
1476 WCHAR *wstr = sv_to_wstr(aTHX_ ST(0));
1477 WCHAR wide_path[MAX_PATH+1];
1480 wcscpy(wide_path, wstr);
1482 long_path = my_longpathW(wide_path);
1484 ST(0) = wstr_to_sv(aTHX_ long_path);
1490 char tmpbuf[MAX_PATH+1];
1495 pathstr = SvPV(path,len);
1496 strcpy(tmpbuf, pathstr);
1497 pathstr = my_longpathA(tmpbuf);
1499 ST(0) = sv_2mortal(newSVpvn(pathstr, strlen(pathstr)));
1506 XS(w32_GetANSIPathName)
1512 Perl_croak(aTHX_ "usage: Win32::GetANSIPathName($pathname)");
1514 wide_path = sv_to_wstr(aTHX_ ST(0));
1515 ST(0) = wstr_to_ansipath(aTHX_ wide_path);
1516 Safefree(wide_path);
1524 Perl_croak(aTHX_ "usage: Win32::Sleep($milliseconds)");
1533 char szSourceFile[MAX_PATH+1];
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)));
1544 XS(w32_OutputDebugString)
1548 Perl_croak(aTHX_ "usage: Win32::OutputDebugString($string)");
1550 if (SvUTF8(ST(0))) {
1551 WCHAR *str = sv_to_wstr(aTHX_ ST(0));
1552 OutputDebugStringW(str);
1556 OutputDebugStringA(SvPV_nolen(ST(0)));
1561 XS(w32_GetCurrentThreadId)
1565 XSRETURN_IV(GetCurrentThreadId());
1568 XS(w32_CreateDirectory)
1574 Perl_croak(aTHX_ "usage: Win32::CreateDirectory($dir)");
1576 if (IsWin2000() && SvUTF8(ST(0))) {
1577 WCHAR *dir = sv_to_wstr(aTHX_ ST(0));
1578 result = CreateDirectoryW(dir, NULL);
1582 result = CreateDirectoryA(SvPV_nolen(ST(0)), NULL);
1585 ST(0) = boolSV(result);
1595 Perl_croak(aTHX_ "usage: Win32::CreateFile($file)");
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);
1604 handle = CreateFileA(SvPV_nolen(ST(0)), GENERIC_WRITE, FILE_SHARE_WRITE,
1605 NULL, CREATE_NEW, FILE_ATTRIBUTE_NORMAL, NULL);
1608 if (handle != INVALID_HANDLE_VALUE)
1609 CloseHandle(handle);
1611 ST(0) = boolSV(handle != INVALID_HANDLE_VALUE);
1615 MODULE = Win32 PACKAGE = Win32
1621 char *file = __FILE__;
1623 if (g_osver.dwOSVersionInfoSize == 0) {
1624 g_osver.dwOSVersionInfoSize = sizeof(g_osver);
1625 if (!GetVersionExA((OSVERSIONINFOA*)&g_osver)) {
1627 g_osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFOA);
1628 GetVersionExA((OSVERSIONINFOA*)&g_osver);
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);
1648 newXS("Win32::GetFileVersion", w32_GetFileVersion, file);
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);
1668 newXS("Win32::GetANSIPathName", w32_GetANSIPathName, file);
1669 newXS("Win32::CopyFile", w32_CopyFile, file);
1670 newXS("Win32::Sleep", w32_Sleep, file);
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);
1676 newXS("Win32::SetChildShowWindow", w32_SetChildShowWindow, file);