-#include <wctype.h>\r
-#include <windows.h>\r
-#include <shlobj.h>\r
-\r
-#define PERL_NO_GET_CONTEXT\r
-#include "EXTERN.h"\r
-#include "perl.h"\r
-#include "XSUB.h"\r
-\r
-#ifndef countof\r
-# define countof(array) (sizeof (array) / sizeof (*(array)))\r
-#endif\r
-\r
-#define SE_SHUTDOWN_NAMEA "SeShutdownPrivilege"\r
-\r
-#ifndef WC_NO_BEST_FIT_CHARS\r
-# define WC_NO_BEST_FIT_CHARS 0x00000400\r
-#endif\r
-\r
-#define GETPROC(fn) pfn##fn = (PFN##fn)GetProcAddress(module, #fn)\r
-\r
-typedef BOOL (WINAPI *PFNSHGetSpecialFolderPathA)(HWND, char*, int, BOOL);\r
-typedef BOOL (WINAPI *PFNSHGetSpecialFolderPathW)(HWND, WCHAR*, int, BOOL);\r
-typedef HRESULT (WINAPI *PFNSHGetFolderPathA)(HWND, int, HANDLE, DWORD, LPTSTR);\r
-typedef HRESULT (WINAPI *PFNSHGetFolderPathW)(HWND, int, HANDLE, DWORD, LPWSTR);\r
-typedef BOOL (WINAPI *PFNCreateEnvironmentBlock)(void**, HANDLE, BOOL);\r
-typedef BOOL (WINAPI *PFNDestroyEnvironmentBlock)(void*);\r
-typedef int (__stdcall *PFNDllRegisterServer)(void);\r
-typedef int (__stdcall *PFNDllUnregisterServer)(void);\r
-typedef DWORD (__stdcall *PFNNetApiBufferFree)(void*);\r
-typedef DWORD (__stdcall *PFNNetWkstaGetInfo)(LPWSTR, DWORD, void*);\r
-\r
-typedef BOOL (__stdcall *PFNOpenProcessToken)(HANDLE, DWORD, HANDLE*);\r
-typedef BOOL (__stdcall *PFNOpenThreadToken)(HANDLE, DWORD, BOOL, HANDLE*);\r
-typedef BOOL (__stdcall *PFNGetTokenInformation)(HANDLE, TOKEN_INFORMATION_CLASS, void*, DWORD, DWORD*);\r
-typedef BOOL (__stdcall *PFNAllocateAndInitializeSid)(PSID_IDENTIFIER_AUTHORITY, BYTE, DWORD, DWORD,\r
- DWORD, DWORD, DWORD, DWORD, DWORD, DWORD, PSID*);\r
-typedef BOOL (__stdcall *PFNEqualSid)(PSID, PSID);\r
-typedef void* (__stdcall *PFNFreeSid)(PSID);\r
-typedef BOOL (__stdcall *PFNIsUserAnAdmin)(void);\r
-typedef BOOL (WINAPI *PFNGetProductInfo)(DWORD, DWORD, DWORD, DWORD, DWORD*);\r
-typedef void (WINAPI *PFNGetNativeSystemInfo)(LPSYSTEM_INFO lpSystemInfo);\r
-\r
-#ifndef CSIDL_MYMUSIC\r
-# define CSIDL_MYMUSIC 0x000D\r
-#endif\r
-#ifndef CSIDL_MYVIDEO\r
-# define CSIDL_MYVIDEO 0x000E\r
-#endif\r
-#ifndef CSIDL_LOCAL_APPDATA\r
-# define CSIDL_LOCAL_APPDATA 0x001C\r
-#endif\r
-#ifndef CSIDL_COMMON_FAVORITES\r
-# define CSIDL_COMMON_FAVORITES 0x001F\r
-#endif\r
-#ifndef CSIDL_INTERNET_CACHE\r
-# define CSIDL_INTERNET_CACHE 0x0020\r
-#endif\r
-#ifndef CSIDL_COOKIES\r
-# define CSIDL_COOKIES 0x0021\r
-#endif\r
-#ifndef CSIDL_HISTORY\r
-# define CSIDL_HISTORY 0x0022\r
-#endif\r
-#ifndef CSIDL_COMMON_APPDATA\r
-# define CSIDL_COMMON_APPDATA 0x0023\r
-#endif\r
-#ifndef CSIDL_WINDOWS\r
-# define CSIDL_WINDOWS 0x0024\r
-#endif\r
-#ifndef CSIDL_PROGRAM_FILES\r
-# define CSIDL_PROGRAM_FILES 0x0026\r
-#endif\r
-#ifndef CSIDL_MYPICTURES\r
-# define CSIDL_MYPICTURES 0x0027\r
-#endif\r
-#ifndef CSIDL_PROFILE\r
-# define CSIDL_PROFILE 0x0028\r
-#endif\r
-#ifndef CSIDL_PROGRAM_FILES_COMMON\r
-# define CSIDL_PROGRAM_FILES_COMMON 0x002B\r
-#endif\r
-#ifndef CSIDL_COMMON_TEMPLATES\r
-# define CSIDL_COMMON_TEMPLATES 0x002D\r
-#endif\r
-#ifndef CSIDL_COMMON_DOCUMENTS\r
-# define CSIDL_COMMON_DOCUMENTS 0x002E\r
-#endif\r
-#ifndef CSIDL_COMMON_ADMINTOOLS\r
-# define CSIDL_COMMON_ADMINTOOLS 0x002F\r
-#endif\r
-#ifndef CSIDL_ADMINTOOLS\r
-# define CSIDL_ADMINTOOLS 0x0030\r
-#endif\r
-#ifndef CSIDL_COMMON_MUSIC\r
-# define CSIDL_COMMON_MUSIC 0x0035\r
-#endif\r
-#ifndef CSIDL_COMMON_PICTURES\r
-# define CSIDL_COMMON_PICTURES 0x0036\r
-#endif\r
-#ifndef CSIDL_COMMON_VIDEO\r
-# define CSIDL_COMMON_VIDEO 0x0037\r
-#endif\r
-#ifndef CSIDL_CDBURN_AREA\r
-# define CSIDL_CDBURN_AREA 0x003B\r
-#endif\r
-#ifndef CSIDL_FLAG_CREATE\r
-# define CSIDL_FLAG_CREATE 0x8000\r
-#endif\r
-\r
-/* Use explicit struct definition because wSuiteMask and\r
- * wProductType are not defined in the VC++ 6.0 headers.\r
- * WORD type has been replaced by unsigned short because\r
- * WORD is already used by Perl itself.\r
- */\r
-struct {\r
- DWORD dwOSVersionInfoSize;\r
- DWORD dwMajorVersion;\r
- DWORD dwMinorVersion;\r
- DWORD dwBuildNumber;\r
- DWORD dwPlatformId;\r
- CHAR szCSDVersion[128];\r
- unsigned short wServicePackMajor;\r
- unsigned short wServicePackMinor;\r
- unsigned short wSuiteMask;\r
- BYTE wProductType;\r
- BYTE wReserved;\r
-} g_osver = {0, 0, 0, 0, 0, "", 0, 0, 0, 0, 0};\r
-BOOL g_osver_ex = TRUE;\r
-\r
-#define ONE_K_BUFSIZE 1024\r
-\r
-int\r
-IsWin95(void)\r
-{\r
- return (g_osver.dwPlatformId == VER_PLATFORM_WIN32_WINDOWS);\r
-}\r
-\r
-int\r
-IsWinNT(void)\r
-{\r
- return (g_osver.dwPlatformId == VER_PLATFORM_WIN32_NT);\r
-}\r
-\r
-int\r
-IsWin2000(void)\r
-{\r
- return (g_osver.dwMajorVersion > 4);\r
-}\r
-\r
-/* Convert SV to wide character string. The return value must be\r
- * freed using Safefree().\r
- */\r
-WCHAR*\r
-sv_to_wstr(pTHX_ SV *sv)\r
-{\r
- DWORD wlen;\r
- WCHAR *wstr;\r
- STRLEN len;\r
- char *str = SvPV(sv, len);\r
- UINT cp = SvUTF8(sv) ? CP_UTF8 : CP_ACP;\r
-\r
- wlen = MultiByteToWideChar(cp, 0, str, (int)(len+1), NULL, 0);\r
- New(0, wstr, wlen, WCHAR);\r
- MultiByteToWideChar(cp, 0, str, (int)(len+1), wstr, wlen);\r
-\r
- return wstr;\r
-}\r
-\r
-/* Convert wide character string to mortal SV. Use UTF8 encoding\r
- * if the string cannot be represented in the system codepage.\r
- */\r
-SV *\r
-wstr_to_sv(pTHX_ WCHAR *wstr)\r
-{\r
- int wlen = (int)wcslen(wstr)+1;\r
- BOOL use_default = FALSE;\r
- int len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, wstr, wlen, NULL, 0, NULL, NULL);\r
- SV *sv = sv_2mortal(newSV(len));\r
-\r
- len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, wstr, wlen, SvPVX(sv), len, NULL, &use_default);\r
- if (use_default) {\r
- len = WideCharToMultiByte(CP_UTF8, 0, wstr, wlen, NULL, 0, NULL, NULL);\r
- sv_grow(sv, len);\r
- len = WideCharToMultiByte(CP_UTF8, 0, wstr, wlen, SvPVX(sv), len, NULL, NULL);\r
- SvUTF8_on(sv);\r
- }\r
- /* Shouldn't really ever fail since we ask for the required length first, but who knows... */\r
- if (len) {\r
- SvPOK_on(sv);\r
- SvCUR_set(sv, len-1);\r
- }\r
- return sv;\r
-}\r
-\r
-/* Retrieve a variable from the Unicode environment in a mortal SV.\r
- *\r
- * Recreates the Unicode environment because a bug in earlier Perl versions\r
- * overwrites it with the ANSI version, which contains replacement\r
- * characters for the characters not in the ANSI codepage.\r
- */\r
-SV*\r
-get_unicode_env(pTHX_ WCHAR *name)\r
-{\r
- SV *sv = NULL;\r
- void *env;\r
- HANDLE token;\r
- HMODULE module;\r
- PFNOpenProcessToken pfnOpenProcessToken;\r
-\r
- /* Get security token for the current process owner */\r
- module = LoadLibrary("advapi32.dll");\r
- if (!module)\r
- return NULL;\r
-\r
- GETPROC(OpenProcessToken);\r
-\r
- if (pfnOpenProcessToken == NULL ||\r
- !pfnOpenProcessToken(GetCurrentProcess(), TOKEN_QUERY | TOKEN_DUPLICATE, &token))\r
- {\r
- FreeLibrary(module);\r
- return NULL;\r
- }\r
- FreeLibrary(module);\r
-\r
- /* Create a Unicode environment block for this process */\r
- module = LoadLibrary("userenv.dll");\r
- if (module) {\r
- PFNCreateEnvironmentBlock pfnCreateEnvironmentBlock;\r
- PFNDestroyEnvironmentBlock pfnDestroyEnvironmentBlock;\r
-\r
- GETPROC(CreateEnvironmentBlock);\r
- GETPROC(DestroyEnvironmentBlock);\r
-\r
- if (pfnCreateEnvironmentBlock && pfnDestroyEnvironmentBlock &&\r
- pfnCreateEnvironmentBlock(&env, token, FALSE))\r
- {\r
- size_t name_len = wcslen(name);\r
- WCHAR *entry = env;\r
- while (*entry) {\r
- size_t i;\r
- size_t entry_len = wcslen(entry);\r
- BOOL equal = (entry_len > name_len) && (entry[name_len] == '=');\r
-\r
- for (i=0; equal && i < name_len; ++i)\r
- equal = (towupper(entry[i]) == towupper(name[i]));\r
-\r
- if (equal) {\r
- sv = wstr_to_sv(aTHX_ entry+name_len+1);\r
- break;\r
- }\r
- entry += entry_len+1;\r
- }\r
- pfnDestroyEnvironmentBlock(env);\r
- }\r
- FreeLibrary(module);\r
- }\r
- CloseHandle(token);\r
- return sv;\r
-}\r
-\r
-/* Define both an ANSI and a Wide version of win32_longpath */\r
-\r
-#define CHAR_T char\r
-#define WIN32_FIND_DATA_T WIN32_FIND_DATAA\r
-#define FN_FINDFIRSTFILE FindFirstFileA\r
-#define FN_STRLEN strlen\r
-#define FN_STRCPY strcpy\r
-#define LONGPATH my_longpathA\r
-#include "longpath.inc"\r
-\r
-#define CHAR_T WCHAR\r
-#define WIN32_FIND_DATA_T WIN32_FIND_DATAW\r
-#define FN_FINDFIRSTFILE FindFirstFileW\r
-#define FN_STRLEN wcslen\r
-#define FN_STRCPY wcscpy\r
-#define LONGPATH my_longpathW\r
-#include "longpath.inc"\r
-\r
-/* The my_ansipath() function takes a Unicode filename and converts it\r
- * into the current Windows codepage. If some characters cannot be mapped,\r
- * then it will convert the short name instead.\r
- *\r
- * The buffer to the ansi pathname must be freed with Safefree() when it\r
- * it no longer needed.\r
- *\r
- * The argument to my_ansipath() must exist before this function is\r
- * called; otherwise there is no way to determine the short path name.\r
- *\r
- * Ideas for future refinement:\r
- * - Only convert those segments of the path that are not in the current\r
- * codepage, but leave the other segments in their long form.\r
- * - If the resulting name is longer than MAX_PATH, start converting\r
- * additional path segments into short names until the full name\r
- * is shorter than MAX_PATH. Shorten the filename part last!\r
- */\r
-\r
-/* This is a modified version of core Perl win32/win32.c(win32_ansipath).\r
- * It uses New() etc. instead of win32_malloc().\r
- */\r
-\r
-char *\r
-my_ansipath(const WCHAR *widename)\r
-{\r
- char *name;\r
- BOOL use_default = FALSE;\r
- int widelen = (int)wcslen(widename)+1;\r
- int len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, widename, widelen,\r
- NULL, 0, NULL, NULL);\r
- New(0, name, len, char);\r
- WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, widename, widelen,\r
- name, len, NULL, &use_default);\r
- if (use_default) {\r
- DWORD shortlen = GetShortPathNameW(widename, NULL, 0);\r
- if (shortlen) {\r
- WCHAR *shortname;\r
- New(0, shortname, shortlen, WCHAR);\r
- shortlen = GetShortPathNameW(widename, shortname, shortlen)+1;\r
-\r
- len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, shortname, shortlen,\r
- NULL, 0, NULL, NULL);\r
- Renew(name, len, char);\r
- WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, shortname, shortlen,\r
- name, len, NULL, NULL);\r
- Safefree(shortname);\r
- }\r
- }\r
- return name;\r
-}\r
-\r
-/* Convert wide character path to ANSI path and return as mortal SV. */\r
-SV*\r
-wstr_to_ansipath(pTHX_ WCHAR *wstr)\r
-{\r
- char *ansi = my_ansipath(wstr);\r
- SV *sv = sv_2mortal(newSVpvn(ansi, strlen(ansi)));\r
- Safefree(ansi);\r
- return sv;\r
-}\r
-\r
-#ifdef __CYGWIN__\r
-\r
-char*\r
-get_childdir(void)\r
-{\r
- dTHX;\r
- char* ptr;\r
-\r
- if (IsWin2000()) {\r
- WCHAR filename[MAX_PATH+1];\r
- GetCurrentDirectoryW(MAX_PATH+1, filename);\r
- ptr = my_ansipath(filename);\r
- }\r
- else {\r
- char filename[MAX_PATH+1];\r
- GetCurrentDirectoryA(MAX_PATH+1, filename);\r
- New(0, ptr, strlen(filename)+1, char);\r
- strcpy(ptr, filename);\r
- }\r
- return ptr;\r
-}\r
-\r
-void\r
-free_childdir(char *d)\r
-{\r
- dTHX;\r
- Safefree(d);\r
-}\r
-\r
-void*\r
-get_childenv(void)\r
-{\r
- return NULL;\r
-}\r
-\r
-void\r
-free_childenv(void *d)\r
-{\r
-}\r
-\r
-# define PerlDir_mapA(dir) (dir)\r
-\r
-#endif\r
-\r
-XS(w32_ExpandEnvironmentStrings)\r
-{\r
- dXSARGS;\r
-\r
- if (items != 1)\r
- croak("usage: Win32::ExpandEnvironmentStrings($String);\n");\r
-\r
- if (IsWin2000()) {\r
- WCHAR value[31*1024];\r
- WCHAR *source = sv_to_wstr(aTHX_ ST(0));\r
- ExpandEnvironmentStringsW(source, value, countof(value)-1);\r
- ST(0) = wstr_to_sv(aTHX_ value);\r
- Safefree(source);\r
- XSRETURN(1);\r
- }\r
- else {\r
- char value[31*1024];\r
- ExpandEnvironmentStringsA(SvPV_nolen(ST(0)), value, countof(value)-2);\r
- XSRETURN_PV(value);\r
- }\r
-}\r
-\r
-XS(w32_IsAdminUser)\r
-{\r
- dXSARGS;\r
- HMODULE module;\r
- PFNIsUserAnAdmin pfnIsUserAnAdmin;\r
- PFNOpenThreadToken pfnOpenThreadToken;\r
- PFNOpenProcessToken pfnOpenProcessToken;\r
- PFNGetTokenInformation pfnGetTokenInformation;\r
- PFNAllocateAndInitializeSid pfnAllocateAndInitializeSid;\r
- PFNEqualSid pfnEqualSid;\r
- PFNFreeSid pfnFreeSid;\r
- HANDLE hTok;\r
- DWORD dwTokInfoLen;\r
- TOKEN_GROUPS *lpTokInfo;\r
- SID_IDENTIFIER_AUTHORITY NtAuth = SECURITY_NT_AUTHORITY;\r
- PSID pAdminSid;\r
- int iRetVal;\r
- unsigned int i;\r
-\r
- if (items)\r
- croak("usage: Win32::IsAdminUser()");\r
-\r
- /* There is no concept of "Administrator" user accounts on Win9x systems,\r
- so just return true. */\r
- if (IsWin95())\r
- XSRETURN_YES;\r
-\r
- /* Use IsUserAnAdmin() when available. On Vista this will only return TRUE\r
- * if the process is running with elevated privileges and not just when the\r
- * process owner is a member of the "Administrators" group.\r
- */\r
- module = LoadLibrary("shell32.dll");\r
- if (module) {\r
- GETPROC(IsUserAnAdmin);\r
- if (pfnIsUserAnAdmin) {\r
- EXTEND(SP, 1);\r
- ST(0) = sv_2mortal(newSViv(pfnIsUserAnAdmin() ? 1 : 0));\r
- FreeLibrary(module);\r
- XSRETURN(1);\r
- }\r
- FreeLibrary(module);\r
- }\r
-\r
- module = LoadLibrary("advapi32.dll");\r
- if (!module) {\r
- warn("Cannot load advapi32.dll library");\r
- XSRETURN_UNDEF;\r
- }\r
-\r
- GETPROC(OpenThreadToken);\r
- GETPROC(OpenProcessToken);\r
- GETPROC(GetTokenInformation);\r
- GETPROC(AllocateAndInitializeSid);\r
- GETPROC(EqualSid);\r
- GETPROC(FreeSid);\r
-\r
- if (!(pfnOpenThreadToken && pfnOpenProcessToken &&\r
- pfnGetTokenInformation && pfnAllocateAndInitializeSid &&\r
- pfnEqualSid && pfnFreeSid))\r
- {\r
- warn("Cannot load functions from advapi32.dll library");\r
- FreeLibrary(module);\r
- XSRETURN_UNDEF;\r
- }\r
-\r
- if (!pfnOpenThreadToken(GetCurrentThread(), TOKEN_QUERY, FALSE, &hTok)) {\r
- if (!pfnOpenProcessToken(GetCurrentProcess(), TOKEN_QUERY, &hTok)) {\r
- warn("Cannot open thread token or process token");\r
- FreeLibrary(module);\r
- XSRETURN_UNDEF;\r
- }\r
- }\r
-\r
- pfnGetTokenInformation(hTok, TokenGroups, NULL, 0, &dwTokInfoLen);\r
- if (!New(1, lpTokInfo, dwTokInfoLen, TOKEN_GROUPS)) {\r
- warn("Cannot allocate token information structure");\r
- CloseHandle(hTok);\r
- FreeLibrary(module);\r
- XSRETURN_UNDEF;\r
- }\r
-\r
- if (!pfnGetTokenInformation(hTok, TokenGroups, lpTokInfo, dwTokInfoLen,\r
- &dwTokInfoLen))\r
- {\r
- warn("Cannot get token information");\r
- Safefree(lpTokInfo);\r
- CloseHandle(hTok);\r
- FreeLibrary(module);\r
- XSRETURN_UNDEF;\r
- }\r
-\r
- if (!pfnAllocateAndInitializeSid(&NtAuth, 2, SECURITY_BUILTIN_DOMAIN_RID,\r
- DOMAIN_ALIAS_RID_ADMINS, 0, 0, 0, 0, 0, 0, &pAdminSid))\r
- {\r
- warn("Cannot allocate administrators' SID");\r
- Safefree(lpTokInfo);\r
- CloseHandle(hTok);\r
- FreeLibrary(module);\r
- XSRETURN_UNDEF;\r
- }\r
-\r
- iRetVal = 0;\r
- for (i = 0; i < lpTokInfo->GroupCount; ++i) {\r
- if (pfnEqualSid(lpTokInfo->Groups[i].Sid, pAdminSid)) {\r
- iRetVal = 1;\r
- break;\r
- }\r
- }\r
-\r
- pfnFreeSid(pAdminSid);\r
- Safefree(lpTokInfo);\r
- CloseHandle(hTok);\r
- FreeLibrary(module);\r
-\r
- EXTEND(SP, 1);\r
- ST(0) = sv_2mortal(newSViv(iRetVal));\r
- XSRETURN(1);\r
-}\r
-\r
-XS(w32_LookupAccountName)\r
-{\r
- dXSARGS;\r
- char SID[400];\r
- DWORD SIDLen;\r
- SID_NAME_USE snu;\r
- char Domain[256];\r
- DWORD DomLen;\r
- BOOL bResult;\r
-\r
- if (items != 5)\r
- croak("usage: Win32::LookupAccountName($system, $account, $domain, "\r
- "$sid, $sidtype);\n");\r
-\r
- SIDLen = sizeof(SID);\r
- DomLen = sizeof(Domain);\r
-\r
- bResult = LookupAccountNameA(SvPV_nolen(ST(0)), /* System */\r
- SvPV_nolen(ST(1)), /* Account name */\r
- &SID, /* SID structure */\r
- &SIDLen, /* Size of SID buffer */\r
- Domain, /* Domain buffer */\r
- &DomLen, /* Domain buffer size */\r
- &snu); /* SID name type */\r
- if (bResult) {\r
- sv_setpv(ST(2), Domain);\r
- sv_setpvn(ST(3), SID, SIDLen);\r
- sv_setiv(ST(4), snu);\r
- XSRETURN_YES;\r
- }\r
- XSRETURN_NO;\r
-}\r
-\r
-\r
-XS(w32_LookupAccountSID)\r
-{\r
- dXSARGS;\r
- PSID sid;\r
- char Account[256];\r
- DWORD AcctLen = sizeof(Account);\r
- char Domain[256];\r
- DWORD DomLen = sizeof(Domain);\r
- SID_NAME_USE snu;\r
- BOOL bResult;\r
-\r
- if (items != 5)\r
- croak("usage: Win32::LookupAccountSID($system, $sid, $account, $domain, $sidtype);\n");\r
-\r
- sid = SvPV_nolen(ST(1));\r
- if (IsValidSid(sid)) {\r
- bResult = LookupAccountSidA(SvPV_nolen(ST(0)), /* System */\r
- sid, /* SID structure */\r
- Account, /* Account name buffer */\r
- &AcctLen, /* name buffer length */\r
- Domain, /* Domain buffer */\r
- &DomLen, /* Domain buffer length */\r
- &snu); /* SID name type */\r
- if (bResult) {\r
- sv_setpv(ST(2), Account);\r
- sv_setpv(ST(3), Domain);\r
- sv_setiv(ST(4), (IV)snu);\r
- XSRETURN_YES;\r
- }\r
- }\r
- XSRETURN_NO;\r
-}\r
-\r
-XS(w32_InitiateSystemShutdown)\r
-{\r
- dXSARGS;\r
- HANDLE hToken; /* handle to process token */\r
- TOKEN_PRIVILEGES tkp; /* pointer to token structure */\r
- BOOL bRet;\r
- char *machineName, *message;\r
-\r
- if (items != 5)\r
- croak("usage: Win32::InitiateSystemShutdown($machineName, $message, "\r
- "$timeOut, $forceClose, $reboot);\n");\r
-\r
- machineName = SvPV_nolen(ST(0));\r
-\r
- if (OpenProcessToken(GetCurrentProcess(),\r
- TOKEN_ADJUST_PRIVILEGES | TOKEN_QUERY,\r
- &hToken))\r
- {\r
- LookupPrivilegeValueA(machineName,\r
- SE_SHUTDOWN_NAMEA,\r
- &tkp.Privileges[0].Luid);\r
-\r
- tkp.PrivilegeCount = 1; /* only setting one */\r
- tkp.Privileges[0].Attributes = SE_PRIVILEGE_ENABLED;\r
-\r
- /* Get shutdown privilege for this process. */\r
- AdjustTokenPrivileges(hToken, FALSE, &tkp, 0,\r
- (PTOKEN_PRIVILEGES)NULL, 0);\r
- }\r
-\r
- message = SvPV_nolen(ST(1));\r
- bRet = InitiateSystemShutdownA(machineName, message, (DWORD)SvIV(ST(2)),\r
- (BOOL)SvIV(ST(3)), (BOOL)SvIV(ST(4)));\r
-\r
- /* Disable shutdown privilege. */\r
- tkp.Privileges[0].Attributes = 0; \r
- AdjustTokenPrivileges(hToken, FALSE, &tkp, 0,\r
- (PTOKEN_PRIVILEGES)NULL, 0); \r
- CloseHandle(hToken);\r
- XSRETURN_IV(bRet);\r
-}\r
-\r
-XS(w32_AbortSystemShutdown)\r
-{\r
- dXSARGS;\r
- HANDLE hToken; /* handle to process token */\r
- TOKEN_PRIVILEGES tkp; /* pointer to token structure */\r
- BOOL bRet;\r
- char *machineName;\r
-\r
- if (items != 1)\r
- croak("usage: Win32::AbortSystemShutdown($machineName);\n");\r
-\r
- machineName = SvPV_nolen(ST(0));\r
-\r
- if (OpenProcessToken(GetCurrentProcess(),\r
- TOKEN_ADJUST_PRIVILEGES | TOKEN_QUERY,\r
- &hToken))\r
- {\r
- LookupPrivilegeValueA(machineName,\r
- SE_SHUTDOWN_NAMEA,\r
- &tkp.Privileges[0].Luid);\r
-\r
- tkp.PrivilegeCount = 1; /* only setting one */\r
- tkp.Privileges[0].Attributes = SE_PRIVILEGE_ENABLED;\r
-\r
- /* Get shutdown privilege for this process. */\r
- AdjustTokenPrivileges(hToken, FALSE, &tkp, 0,\r
- (PTOKEN_PRIVILEGES)NULL, 0);\r
- }\r
-\r
- bRet = AbortSystemShutdownA(machineName);\r
-\r
- /* Disable shutdown privilege. */\r
- tkp.Privileges[0].Attributes = 0;\r
- AdjustTokenPrivileges(hToken, FALSE, &tkp, 0,\r
- (PTOKEN_PRIVILEGES)NULL, 0);\r
- CloseHandle(hToken);\r
- XSRETURN_IV(bRet);\r
-}\r
-\r
-\r
-XS(w32_MsgBox)\r
-{\r
- dXSARGS;\r
- DWORD flags = MB_ICONEXCLAMATION;\r
- I32 result;\r
-\r
- if (items < 1 || items > 3)\r
- croak("usage: Win32::MsgBox($message [, $flags [, $title]]);\n");\r
-\r
- if (items > 1)\r
- flags = (DWORD)SvIV(ST(1));\r
-\r
- if (IsWin2000()) {\r
- WCHAR *title = NULL;\r
- WCHAR *msg = sv_to_wstr(aTHX_ ST(0));\r
- if (items > 2)\r
- title = sv_to_wstr(aTHX_ ST(2));\r
- result = MessageBoxW(GetActiveWindow(), msg, title ? title : L"Perl", flags);\r
- Safefree(msg);\r
- if (title)\r
- Safefree(title);\r
- }\r
- else {\r
- char *title = "Perl";\r
- char *msg = SvPV_nolen(ST(0));\r
- if (items > 2)\r
- title = SvPV_nolen(ST(2));\r
- result = MessageBoxA(GetActiveWindow(), msg, title, flags);\r
- }\r
- XSRETURN_IV(result);\r
-}\r
-\r
-XS(w32_LoadLibrary)\r
-{\r
- dXSARGS;\r
- HANDLE hHandle;\r
-\r
- if (items != 1)\r
- croak("usage: Win32::LoadLibrary($libname)\n");\r
- hHandle = LoadLibraryA(SvPV_nolen(ST(0)));\r
-#ifdef _WIN64\r
- XSRETURN_IV((DWORD_PTR)hHandle);\r
-#else\r
- XSRETURN_IV((DWORD)hHandle);\r
-#endif\r
-}\r
-\r
-XS(w32_FreeLibrary)\r
-{\r
- dXSARGS;\r
-\r
- if (items != 1)\r
- croak("usage: Win32::FreeLibrary($handle)\n");\r
- if (FreeLibrary(INT2PTR(HINSTANCE, SvIV(ST(0))))) {\r
- XSRETURN_YES;\r
- }\r
- XSRETURN_NO;\r
-}\r
-\r
-XS(w32_GetProcAddress)\r
-{\r
- dXSARGS;\r
-\r
- if (items != 2)\r
- croak("usage: Win32::GetProcAddress($hinstance, $procname)\n");\r
- XSRETURN_IV(PTR2IV(GetProcAddress(INT2PTR(HINSTANCE, SvIV(ST(0))), SvPV_nolen(ST(1)))));\r
-}\r
-\r
-XS(w32_RegisterServer)\r
-{\r
- dXSARGS;\r
- BOOL result = FALSE;\r
- HMODULE module;\r
-\r
- if (items != 1)\r
- croak("usage: Win32::RegisterServer($libname)\n");\r
-\r
- module = LoadLibraryA(SvPV_nolen(ST(0)));\r
- if (module) {\r
- PFNDllRegisterServer pfnDllRegisterServer;\r
- GETPROC(DllRegisterServer);\r
- if (pfnDllRegisterServer && pfnDllRegisterServer() == 0)\r
- result = TRUE;\r
- FreeLibrary(module);\r
- }\r
- ST(0) = boolSV(result);\r
- XSRETURN(1);\r
-}\r
-\r
-XS(w32_UnregisterServer)\r
-{\r
- dXSARGS;\r
- BOOL result = FALSE;\r
- HINSTANCE module;\r
-\r
- if (items != 1)\r
- croak("usage: Win32::UnregisterServer($libname)\n");\r
-\r
- module = LoadLibraryA(SvPV_nolen(ST(0)));\r
- if (module) {\r
- PFNDllUnregisterServer pfnDllUnregisterServer;\r
- GETPROC(DllUnregisterServer);\r
- if (pfnDllUnregisterServer && pfnDllUnregisterServer() == 0)\r
- result = TRUE;\r
- FreeLibrary(module);\r
- }\r
- ST(0) = boolSV(result);\r
- XSRETURN(1);\r
-}\r
-\r
-/* XXX rather bogus */\r
-XS(w32_GetArchName)\r
-{\r
- dXSARGS;\r
- XSRETURN_PV(getenv("PROCESSOR_ARCHITECTURE"));\r
-}\r
-\r
-XS(w32_GetChipName)\r
-{\r
- dXSARGS;\r
- SYSTEM_INFO sysinfo;\r
- HMODULE module;\r
- PFNGetNativeSystemInfo pfnGetNativeSystemInfo;\r
-\r
- Zero(&sysinfo,1,SYSTEM_INFO);\r
- module = GetModuleHandle("kernel32.dll");\r
- GETPROC(GetNativeSystemInfo);\r
- if (pfnGetNativeSystemInfo)\r
- pfnGetNativeSystemInfo(&sysinfo);\r
- else\r
- GetSystemInfo(&sysinfo);\r
-\r
- /* XXX docs say dwProcessorType is deprecated on NT */\r
- XSRETURN_IV(sysinfo.dwProcessorType);\r
-}\r
-\r
-XS(w32_GuidGen)\r
-{\r
- dXSARGS;\r
- GUID guid;\r
- char szGUID[50] = {'\0'};\r
- HRESULT hr = CoCreateGuid(&guid);\r
-\r
- if (SUCCEEDED(hr)) {\r
- LPOLESTR pStr = NULL;\r
- if (SUCCEEDED(StringFromCLSID(&guid, &pStr))) {\r
- WideCharToMultiByte(CP_ACP, 0, pStr, (int)wcslen(pStr), szGUID,\r
- sizeof(szGUID), NULL, NULL);\r
- CoTaskMemFree(pStr);\r
- XSRETURN_PV(szGUID);\r
- }\r
- }\r
- XSRETURN_UNDEF;\r
-}\r
-\r
-XS(w32_GetFolderPath)\r
-{\r
- dXSARGS;\r
- char path[MAX_PATH+1];\r
- WCHAR wpath[MAX_PATH+1];\r
- int folder;\r
- int create = 0;\r
- HMODULE module;\r
-\r
- if (items != 1 && items != 2)\r
- croak("usage: Win32::GetFolderPath($csidl [, $create])\n");\r
-\r
- folder = (int)SvIV(ST(0));\r
- if (items == 2)\r
- create = SvTRUE(ST(1)) ? CSIDL_FLAG_CREATE : 0;\r
-\r
- module = LoadLibrary("shfolder.dll");\r
- if (module) {\r
- PFNSHGetFolderPathA pfna;\r
- if (IsWin2000()) {\r
- PFNSHGetFolderPathW pfnw;\r
- pfnw = (PFNSHGetFolderPathW)GetProcAddress(module, "SHGetFolderPathW");\r
- if (pfnw && SUCCEEDED(pfnw(NULL, folder|create, NULL, 0, wpath))) {\r
- FreeLibrary(module);\r
- ST(0) = wstr_to_ansipath(aTHX_ wpath);\r
- XSRETURN(1);\r
- }\r
- }\r
- pfna = (PFNSHGetFolderPathA)GetProcAddress(module, "SHGetFolderPathA");\r
- if (pfna && SUCCEEDED(pfna(NULL, folder|create, NULL, 0, path))) {\r
- FreeLibrary(module);\r
- XSRETURN_PV(path);\r
- }\r
- FreeLibrary(module);\r
- }\r
-\r
- module = LoadLibrary("shell32.dll");\r
- if (module) {\r
- PFNSHGetSpecialFolderPathA pfna;\r
- if (IsWin2000()) {\r
- PFNSHGetSpecialFolderPathW pfnw;\r
- pfnw = (PFNSHGetSpecialFolderPathW)GetProcAddress(module, "SHGetSpecialFolderPathW");\r
- if (pfnw && pfnw(NULL, wpath, folder, !!create)) {\r
- FreeLibrary(module);\r
- ST(0) = wstr_to_ansipath(aTHX_ wpath);\r
- XSRETURN(1);\r
- }\r
- }\r
- pfna = (PFNSHGetSpecialFolderPathA)GetProcAddress(module, "SHGetSpecialFolderPathA");\r
- if (pfna && pfna(NULL, path, folder, !!create)) {\r
- FreeLibrary(module);\r
- XSRETURN_PV(path);\r
- }\r
- FreeLibrary(module);\r
- }\r
-\r
- /* SHGetFolderPathW() and SHGetSpecialFolderPathW() may fail on older\r
- * Perl versions that have replaced the Unicode environment with an\r
- * ANSI version. Let's go spelunking in the registry now...\r
- */\r
- if (IsWin2000()) {\r
- SV *sv;\r
- HKEY hkey;\r
- HKEY root = HKEY_CURRENT_USER;\r
- WCHAR *name = NULL;\r
-\r
- switch (folder) {\r
- case CSIDL_ADMINTOOLS: name = L"Administrative Tools"; break;\r
- case CSIDL_APPDATA: name = L"AppData"; break;\r
- case CSIDL_CDBURN_AREA: name = L"CD Burning"; break;\r
- case CSIDL_COOKIES: name = L"Cookies"; break;\r
- case CSIDL_DESKTOP:\r
- case CSIDL_DESKTOPDIRECTORY: name = L"Desktop"; break;\r
- case CSIDL_FAVORITES: name = L"Favorites"; break;\r
- case CSIDL_FONTS: name = L"Fonts"; break;\r
- case CSIDL_HISTORY: name = L"History"; break;\r
- case CSIDL_INTERNET_CACHE: name = L"Cache"; break;\r
- case CSIDL_LOCAL_APPDATA: name = L"Local AppData"; break;\r
- case CSIDL_MYMUSIC: name = L"My Music"; break;\r
- case CSIDL_MYPICTURES: name = L"My Pictures"; break;\r
- case CSIDL_MYVIDEO: name = L"My Video"; break;\r
- case CSIDL_NETHOOD: name = L"NetHood"; break;\r
- case CSIDL_PERSONAL: name = L"Personal"; break;\r
- case CSIDL_PRINTHOOD: name = L"PrintHood"; break;\r
- case CSIDL_PROGRAMS: name = L"Programs"; break;\r
- case CSIDL_RECENT: name = L"Recent"; break;\r
- case CSIDL_SENDTO: name = L"SendTo"; break;\r
- case CSIDL_STARTMENU: name = L"Start Menu"; break;\r
- case CSIDL_STARTUP: name = L"Startup"; break;\r
- case CSIDL_TEMPLATES: name = L"Templates"; break;\r
- /* XXX L"Local Settings" */\r
- }\r
-\r
- if (!name) {\r
- root = HKEY_LOCAL_MACHINE;\r
- switch (folder) {\r
- case CSIDL_COMMON_ADMINTOOLS: name = L"Common Administrative Tools"; break;\r
- case CSIDL_COMMON_APPDATA: name = L"Common AppData"; break;\r
- case CSIDL_COMMON_DESKTOPDIRECTORY: name = L"Common Desktop"; break;\r
- case CSIDL_COMMON_DOCUMENTS: name = L"Common Documents"; break;\r
- case CSIDL_COMMON_FAVORITES: name = L"Common Favorites"; break;\r
- case CSIDL_COMMON_PROGRAMS: name = L"Common Programs"; break;\r
- case CSIDL_COMMON_STARTMENU: name = L"Common Start Menu"; break;\r
- case CSIDL_COMMON_STARTUP: name = L"Common Startup"; break;\r
- case CSIDL_COMMON_TEMPLATES: name = L"Common Templates"; break;\r
- case CSIDL_COMMON_MUSIC: name = L"CommonMusic"; break;\r
- case CSIDL_COMMON_PICTURES: name = L"CommonPictures"; break;\r
- case CSIDL_COMMON_VIDEO: name = L"CommonVideo"; break;\r
- }\r
- }\r
- /* XXX todo\r
- * case CSIDL_SYSTEM # GetSystemDirectory()\r
- * case CSIDL_RESOURCES # %windir%\Resources\, For theme and other windows resources.\r
- * case CSIDL_RESOURCES_LOCALIZED # %windir%\Resources\<LangID>, for theme and other windows specific resources.\r
- */\r
-\r
-#define SHELL_FOLDERS "Software\\Microsoft\\Windows\\CurrentVersion\\Explorer\\Shell Folders"\r
-\r
- if (name && RegOpenKeyEx(root, SHELL_FOLDERS, 0, KEY_QUERY_VALUE, &hkey) == ERROR_SUCCESS) {\r
- WCHAR data[MAX_PATH+1];\r
- DWORD cb = sizeof(data)-sizeof(WCHAR);\r
- DWORD type = REG_NONE;\r
- long rc = RegQueryValueExW(hkey, name, NULL, &type, (BYTE*)&data, &cb);\r
- RegCloseKey(hkey);\r
- if (rc == ERROR_SUCCESS && type == REG_SZ && cb > sizeof(WCHAR) && data[0]) {\r
- /* Make sure the string is properly terminated */\r
- data[cb/sizeof(WCHAR)] = '\0';\r
- ST(0) = wstr_to_ansipath(aTHX_ data);\r
- XSRETURN(1);\r
- }\r
- }\r
-\r
-#undef SHELL_FOLDERS\r
-\r
- /* Unders some circumstances the registry entries seem to have a null string\r
- * as their value even when the directory already exists. The environment\r
- * variables do get set though, so try re-create a Unicode environment and\r
- * check if they are there.\r
- */\r
- sv = NULL;\r
- switch (folder) {\r
- case CSIDL_APPDATA: sv = get_unicode_env(aTHX_ L"APPDATA"); break;\r
- case CSIDL_PROFILE: sv = get_unicode_env(aTHX_ L"USERPROFILE"); break;\r
- case CSIDL_PROGRAM_FILES: sv = get_unicode_env(aTHX_ L"ProgramFiles"); break;\r
- case CSIDL_PROGRAM_FILES_COMMON: sv = get_unicode_env(aTHX_ L"CommonProgramFiles"); break;\r
- case CSIDL_WINDOWS: sv = get_unicode_env(aTHX_ L"SystemRoot"); break;\r
- }\r
- if (sv) {\r
- ST(0) = sv;\r
- XSRETURN(1);\r
- }\r
- }\r
-\r
- XSRETURN_UNDEF;\r
-}\r
-\r
-XS(w32_GetFileVersion)\r
-{\r
- dXSARGS;\r
- DWORD size;\r
- DWORD handle;\r
- char *filename;\r
- char *data;\r
-\r
- if (items != 1)\r
- croak("usage: Win32::GetFileVersion($filename)\n");\r
-\r
- filename = SvPV_nolen(ST(0));\r
- size = GetFileVersionInfoSize(filename, &handle);\r
- if (!size)\r
- XSRETURN_UNDEF;\r
-\r
- New(0, data, size, char);\r
- if (!data)\r
- XSRETURN_UNDEF;\r
-\r
- if (GetFileVersionInfo(filename, handle, size, data)) {\r
- VS_FIXEDFILEINFO *info;\r
- UINT len;\r
- if (VerQueryValue(data, "\\", (void**)&info, &len)) {\r
- int dwValueMS1 = (info->dwFileVersionMS>>16);\r
- int dwValueMS2 = (info->dwFileVersionMS&0xffff);\r
- int dwValueLS1 = (info->dwFileVersionLS>>16);\r
- int dwValueLS2 = (info->dwFileVersionLS&0xffff);\r
-\r
- if (GIMME_V == G_ARRAY) {\r
- EXTEND(SP, 4);\r
- XST_mIV(0, dwValueMS1);\r
- XST_mIV(1, dwValueMS2);\r
- XST_mIV(2, dwValueLS1);\r
- XST_mIV(3, dwValueLS2);\r
- items = 4;\r
- }\r
- else {\r
- char version[50];\r
- sprintf(version, "%d.%d.%d.%d", dwValueMS1, dwValueMS2, dwValueLS1, dwValueLS2);\r
- XST_mPV(0, version);\r
- }\r
- }\r
- }\r
- else\r
- items = 0;\r
-\r
- Safefree(data);\r
- XSRETURN(items);\r
-}\r
-\r
-#ifdef __CYGWIN__\r
-XS(w32_SetChildShowWindow)\r
-{\r
- /* This function doesn't do anything useful for cygwin. In the\r
- * MSWin32 case it modifies w32_showwindow, which is used by\r
- * win32_spawnvp(). Since w32_showwindow is an internal variable\r
- * inside the thread_intern structure, the MSWin32 implementation\r
- * lives in win32/win32.c in the core Perl distribution.\r
- */\r
- dXSARGS;\r
- XSRETURN_UNDEF;\r
-}\r
-#endif\r
-\r
-XS(w32_GetCwd)\r
-{\r
- dXSARGS;\r
- /* Make the host for current directory */\r
- char* ptr = PerlEnv_get_childdir();\r
- /*\r
- * If ptr != Nullch\r
- * then it worked, set PV valid,\r
- * else return 'undef'\r
- */\r
- if (ptr) {\r
- SV *sv = sv_newmortal();\r
- sv_setpv(sv, ptr);\r
- PerlEnv_free_childdir(ptr);\r
-\r
-#ifndef INCOMPLETE_TAINTS\r
- SvTAINTED_on(sv);\r
-#endif\r
-\r
- EXTEND(SP,1);\r
- ST(0) = sv;\r
- XSRETURN(1);\r
- }\r
- XSRETURN_UNDEF;\r
-}\r
-\r
-XS(w32_SetCwd)\r
-{\r
- dXSARGS;\r
- if (items != 1)\r
- Perl_croak(aTHX_ "usage: Win32::SetCwd($cwd)");\r
-\r
- if (IsWin2000() && SvUTF8(ST(0))) {\r
- WCHAR *wide = sv_to_wstr(aTHX_ ST(0));\r
- char *ansi = my_ansipath(wide);\r
- int rc = PerlDir_chdir(ansi);\r
- Safefree(wide);\r
- Safefree(ansi);\r
- if (!rc)\r
- XSRETURN_YES;\r
- }\r
- else {\r
- if (!PerlDir_chdir(SvPV_nolen(ST(0))))\r
- XSRETURN_YES;\r
- }\r
-\r
- XSRETURN_NO;\r
-}\r
-\r
-XS(w32_GetNextAvailDrive)\r
-{\r
- dXSARGS;\r
- char ix = 'C';\r
- char root[] = "_:\\";\r
-\r
- EXTEND(SP,1);\r
- while (ix <= 'Z') {\r
- root[0] = ix++;\r
- if (GetDriveType(root) == 1) {\r
- root[2] = '\0';\r
- XSRETURN_PV(root);\r
- }\r
- }\r
- XSRETURN_UNDEF;\r
-}\r
-\r
-XS(w32_GetLastError)\r
-{\r
- dXSARGS;\r
- EXTEND(SP,1);\r
- XSRETURN_IV(GetLastError());\r
-}\r
-\r
-XS(w32_SetLastError)\r
-{\r
- dXSARGS;\r
- if (items != 1)\r
- Perl_croak(aTHX_ "usage: Win32::SetLastError($error)");\r
- SetLastError((DWORD)SvIV(ST(0)));\r
- XSRETURN_EMPTY;\r
-}\r
-\r
-XS(w32_LoginName)\r
-{\r
- dXSARGS;\r
- EXTEND(SP,1);\r
- if (IsWin2000()) {\r
- WCHAR name[128];\r
- DWORD size = countof(name);\r
- if (GetUserNameW(name, &size)) {\r
- ST(0) = wstr_to_sv(aTHX_ name);\r
- XSRETURN(1);\r
- }\r
- }\r
- else {\r
- char name[128];\r
- DWORD size = countof(name);\r
- if (GetUserNameA(name, &size)) {\r
- /* size includes NULL */\r
- ST(0) = sv_2mortal(newSVpvn(name, size-1));\r
- XSRETURN(1);\r
- }\r
- }\r
- XSRETURN_UNDEF;\r
-}\r
-\r
-XS(w32_NodeName)\r
-{\r
- dXSARGS;\r
- char name[MAX_COMPUTERNAME_LENGTH+1];\r
- DWORD size = sizeof(name);\r
- EXTEND(SP,1);\r
- if (GetComputerName(name,&size)) {\r
- /* size does NOT include NULL :-( */\r
- ST(0) = sv_2mortal(newSVpvn(name,size));\r
- XSRETURN(1);\r
- }\r
- XSRETURN_UNDEF;\r
-}\r
-\r
-\r
-XS(w32_DomainName)\r
-{\r
- dXSARGS;\r
- HMODULE module = LoadLibrary("netapi32.dll");\r
- PFNNetApiBufferFree pfnNetApiBufferFree;\r
- PFNNetWkstaGetInfo pfnNetWkstaGetInfo;\r
-\r
- if (module) {\r
- GETPROC(NetApiBufferFree);\r
- GETPROC(NetWkstaGetInfo);\r
- }\r
- EXTEND(SP,1);\r
- if (module && pfnNetWkstaGetInfo && pfnNetApiBufferFree) {\r
- /* this way is more reliable, in case user has a local account. */\r
- char dname[256];\r
- DWORD dnamelen = sizeof(dname);\r
- struct {\r
- DWORD wki100_platform_id;\r
- LPWSTR wki100_computername;\r
- LPWSTR wki100_langroup;\r
- DWORD wki100_ver_major;\r
- DWORD wki100_ver_minor;\r
- } *pwi;\r
- DWORD retval;\r
- retval = pfnNetWkstaGetInfo(NULL, 100, &pwi);\r
- /* NERR_Success *is* 0*/\r
- if (retval == 0) {\r
- if (pwi->wki100_langroup && *(pwi->wki100_langroup)) {\r
- WideCharToMultiByte(CP_ACP, 0, pwi->wki100_langroup,\r
- -1, (LPSTR)dname, dnamelen, NULL, NULL);\r
- }\r
- else {\r
- WideCharToMultiByte(CP_ACP, 0, pwi->wki100_computername,\r
- -1, (LPSTR)dname, dnamelen, NULL, NULL);\r
- }\r
- pfnNetApiBufferFree(pwi);\r
- FreeLibrary(module);\r
- XSRETURN_PV(dname);\r
- }\r
- FreeLibrary(module);\r
- SetLastError(retval);\r
- }\r
- else {\r
- /* Win95 doesn't have NetWksta*(), so do it the old way */\r
- char name[256];\r
- DWORD size = sizeof(name);\r
- if (module)\r
- FreeLibrary(module);\r
- if (GetUserName(name,&size)) {\r
- char sid[ONE_K_BUFSIZE];\r
- DWORD sidlen = sizeof(sid);\r
- char dname[256];\r
- DWORD dnamelen = sizeof(dname);\r
- SID_NAME_USE snu;\r
- if (LookupAccountName(NULL, name, (PSID)&sid, &sidlen,\r
- dname, &dnamelen, &snu)) {\r
- XSRETURN_PV(dname); /* all that for this */\r
- }\r
- }\r
- }\r
- XSRETURN_UNDEF;\r
-}\r
-\r
-XS(w32_FsType)\r
-{\r
- dXSARGS;\r
- char fsname[256];\r
- DWORD flags, filecomplen;\r
- if (GetVolumeInformation(NULL, NULL, 0, NULL, &filecomplen,\r
- &flags, fsname, sizeof(fsname))) {\r
- if (GIMME_V == G_ARRAY) {\r
- XPUSHs(sv_2mortal(newSVpvn(fsname,strlen(fsname))));\r
- XPUSHs(sv_2mortal(newSViv(flags)));\r
- XPUSHs(sv_2mortal(newSViv(filecomplen)));\r
- PUTBACK;\r
- return;\r
- }\r
- EXTEND(SP,1);\r
- XSRETURN_PV(fsname);\r
- }\r
- XSRETURN_EMPTY;\r
-}\r
-\r
-XS(w32_GetOSVersion)\r
-{\r
- dXSARGS;\r
-\r
- if (GIMME_V == G_SCALAR) {\r
- XSRETURN_IV(g_osver.dwPlatformId);\r
- }\r
- XPUSHs(sv_2mortal(newSVpvn(g_osver.szCSDVersion, strlen(g_osver.szCSDVersion))));\r
-\r
- XPUSHs(sv_2mortal(newSViv(g_osver.dwMajorVersion)));\r
- XPUSHs(sv_2mortal(newSViv(g_osver.dwMinorVersion)));\r
- XPUSHs(sv_2mortal(newSViv(g_osver.dwBuildNumber)));\r
- XPUSHs(sv_2mortal(newSViv(g_osver.dwPlatformId)));\r
- if (g_osver_ex) {\r
- XPUSHs(sv_2mortal(newSViv(g_osver.wServicePackMajor)));\r
- XPUSHs(sv_2mortal(newSViv(g_osver.wServicePackMinor)));\r
- XPUSHs(sv_2mortal(newSViv(g_osver.wSuiteMask)));\r
- XPUSHs(sv_2mortal(newSViv(g_osver.wProductType)));\r
- }\r
- PUTBACK;\r
-}\r
-\r
-XS(w32_IsWinNT)\r
-{\r
- dXSARGS;\r
- EXTEND(SP,1);\r
- XSRETURN_IV(IsWinNT());\r
-}\r
-\r
-XS(w32_IsWin95)\r
-{\r
- dXSARGS;\r
- EXTEND(SP,1);\r
- XSRETURN_IV(IsWin95());\r
-}\r
-\r
-XS(w32_FormatMessage)\r
-{\r
- dXSARGS;\r
- DWORD source = 0;\r
- char msgbuf[ONE_K_BUFSIZE];\r
-\r
- if (items != 1)\r
- Perl_croak(aTHX_ "usage: Win32::FormatMessage($errno)");\r
-\r
- if (FormatMessageA(FORMAT_MESSAGE_FROM_SYSTEM,\r
- &source, (DWORD)SvIV(ST(0)), 0,\r
- msgbuf, sizeof(msgbuf)-1, NULL))\r
- {\r
- XSRETURN_PV(msgbuf);\r
- }\r
-\r
- XSRETURN_UNDEF;\r
-}\r
-\r
-XS(w32_Spawn)\r
-{\r
- dXSARGS;\r
- char *cmd, *args;\r
- void *env;\r
- char *dir;\r
- PROCESS_INFORMATION stProcInfo;\r
- STARTUPINFO stStartInfo;\r
- BOOL bSuccess = FALSE;\r
-\r
- if (items != 3)\r
- Perl_croak(aTHX_ "usage: Win32::Spawn($cmdName, $args, $PID)");\r
-\r
- cmd = SvPV_nolen(ST(0));\r
- args = SvPV_nolen(ST(1));\r
-\r
- env = PerlEnv_get_childenv();\r
- dir = PerlEnv_get_childdir();\r
-\r
- memset(&stStartInfo, 0, sizeof(stStartInfo)); /* Clear the block */\r
- stStartInfo.cb = sizeof(stStartInfo); /* Set the structure size */\r
- stStartInfo.dwFlags = STARTF_USESHOWWINDOW; /* Enable wShowWindow control */\r
- stStartInfo.wShowWindow = SW_SHOWMINNOACTIVE; /* Start min (normal) */\r
-\r
- if (CreateProcess(\r
- cmd, /* Image path */\r
- args, /* Arguments for command line */\r
- NULL, /* Default process security */\r
- NULL, /* Default thread security */\r
- FALSE, /* Must be TRUE to use std handles */\r
- NORMAL_PRIORITY_CLASS, /* No special scheduling */\r
- env, /* Inherit our environment block */\r
- dir, /* Inherit our currrent directory */\r
- &stStartInfo, /* -> Startup info */\r
- &stProcInfo)) /* <- Process info (if OK) */\r
- {\r
- int pid = (int)stProcInfo.dwProcessId;\r
- if (IsWin95() && pid < 0)\r
- pid = -pid;\r
- sv_setiv(ST(2), pid);\r
- CloseHandle(stProcInfo.hThread);/* library source code does this. */\r
- bSuccess = TRUE;\r
- }\r
- PerlEnv_free_childenv(env);\r
- PerlEnv_free_childdir(dir);\r
- XSRETURN_IV(bSuccess);\r
-}\r
-\r
-XS(w32_GetTickCount)\r
-{\r
- dXSARGS;\r
- DWORD msec = GetTickCount();\r
- EXTEND(SP,1);\r
- if ((IV)msec > 0)\r
- XSRETURN_IV(msec);\r
- XSRETURN_NV(msec);\r
-}\r
-\r
-XS(w32_GetShortPathName)\r
-{\r
- dXSARGS;\r
- SV *shortpath;\r
- DWORD len;\r
-\r
- if (items != 1)\r
- Perl_croak(aTHX_ "usage: Win32::GetShortPathName($longPathName)");\r
-\r
- if (IsWin2000()) {\r
- WCHAR wshort[MAX_PATH+1];\r
- WCHAR *wlong = sv_to_wstr(aTHX_ ST(0));\r
- len = GetShortPathNameW(wlong, wshort, countof(wshort));\r
- Safefree(wlong);\r
- if (len && len < sizeof(wshort)) {\r
- ST(0) = wstr_to_sv(aTHX_ wshort);\r
- XSRETURN(1);\r
- }\r
- XSRETURN_UNDEF;\r
- }\r
-\r
- shortpath = sv_mortalcopy(ST(0));\r
- SvUPGRADE(shortpath, SVt_PV);\r
- if (!SvPVX(shortpath) || !SvLEN(shortpath))\r
- XSRETURN_UNDEF;\r
-\r
- /* src == target is allowed */\r
- do {\r
- len = GetShortPathName(SvPVX(shortpath),\r
- SvPVX(shortpath),\r
- (DWORD)SvLEN(shortpath));\r
- } while (len >= SvLEN(shortpath) && sv_grow(shortpath,len+1));\r
- if (len) {\r
- SvCUR_set(shortpath,len);\r
- *SvEND(shortpath) = '\0';\r
- ST(0) = shortpath;\r
- XSRETURN(1);\r
- }\r
- XSRETURN_UNDEF;\r
-}\r
-\r
-XS(w32_GetFullPathName)\r
-{\r
- dXSARGS;\r
- char *fullname;\r
- char *ansi = NULL;\r
-\r
-/* The code below relies on the fact that PerlDir_mapX() returns an\r
- * absolute path, which is only true under PERL_IMPLICIT_SYS when\r
- * we use the virtualization code from win32/vdir.h.\r
- * Without it PerlDir_mapX() is a no-op and we need to use the same\r
- * code as we use for Cygwin.\r
- */\r
-#if __CYGWIN__ || !defined(PERL_IMPLICIT_SYS)\r
- char buffer[2*MAX_PATH];\r
-#endif\r
-\r
- if (items != 1)\r
- Perl_croak(aTHX_ "usage: Win32::GetFullPathName($filename)");\r
-\r
-#if __CYGWIN__ || !defined(PERL_IMPLICIT_SYS)\r
- if (IsWin2000()) {\r
- WCHAR *filename = sv_to_wstr(aTHX_ ST(0));\r
- WCHAR full[2*MAX_PATH];\r
- DWORD len = GetFullPathNameW(filename, countof(full), full, NULL);\r
- Safefree(filename);\r
- if (len == 0 || len >= countof(full))\r
- XSRETURN_EMPTY;\r
- ansi = fullname = my_ansipath(full);\r
- }\r
- else {\r
- DWORD len = GetFullPathNameA(SvPV_nolen(ST(0)), countof(buffer), buffer, NULL);\r
- if (len == 0 || len >= countof(buffer))\r
- XSRETURN_EMPTY;\r
- fullname = buffer;\r
- }\r
-#else\r
- /* Don't use my_ansipath() unless the $filename argument is in Unicode.\r
- * If the relative path doesn't exist, GetShortPathName() will fail and\r
- * my_ansipath() will use the long name with replacement characters.\r
- * In that case we will be better off using PerlDir_mapA(), which\r
- * already uses the ANSI name of the current directory.\r
- *\r
- * XXX The one missing case is where we could downgrade $filename\r
- * XXX from UTF8 into the current codepage.\r
- */\r
- if (IsWin2000() && SvUTF8(ST(0))) {\r
- WCHAR *filename = sv_to_wstr(aTHX_ ST(0));\r
- WCHAR *mappedname = PerlDir_mapW(filename);\r
- Safefree(filename);\r
- ansi = fullname = my_ansipath(mappedname);\r
- }\r
- else {\r
- fullname = PerlDir_mapA(SvPV_nolen(ST(0)));\r
- }\r
-# if PERL_VERSION < 8\r
- {\r
- /* PerlDir_mapX() in Perl 5.6 used to return forward slashes */\r
- char *str = fullname;\r
- while (*str) {\r
- if (*str == '/')\r
- *str = '\\';\r
- ++str;\r
- }\r
- }\r
-# endif\r
-#endif\r
-\r
- /* GetFullPathName() on Windows NT drops trailing backslash */\r
- if (g_osver.dwMajorVersion == 4 && *fullname) {\r
- STRLEN len;\r
- char *pv = SvPV(ST(0), len);\r
- char *lastchar = fullname + strlen(fullname) - 1;\r
- /* If ST(0) ends with a slash, but fullname doesn't ... */\r
- if (len && (pv[len-1] == '/' || pv[len-1] == '\\') && *lastchar != '\\') {\r
- /* fullname is the MAX_PATH+1 sized buffer returned from PerlDir_mapA()\r
- * or the 2*MAX_PATH sized local buffer in the __CYGWIN__ case.\r
- */\r
- if (lastchar - fullname < MAX_PATH - 1)\r
- strcpy(lastchar+1, "\\");\r
- }\r
- }\r
-\r
- if (GIMME_V == G_ARRAY) {\r
- char *filepart = strrchr(fullname, '\\');\r
-\r
- EXTEND(SP,1);\r
- if (filepart) {\r
- XST_mPV(1, ++filepart);\r
- *filepart = '\0';\r
- }\r
- else {\r
- XST_mPVN(1, "", 0);\r
- }\r
- items = 2;\r
- }\r
- XST_mPV(0, fullname);\r
-\r
- if (ansi)\r
- Safefree(ansi);\r
- XSRETURN(items);\r
-}\r
-\r
-XS(w32_GetLongPathName)\r
-{\r
- dXSARGS;\r
-\r
- if (items != 1)\r
- Perl_croak(aTHX_ "usage: Win32::GetLongPathName($pathname)");\r
-\r
- if (IsWin2000()) {\r
- WCHAR *wstr = sv_to_wstr(aTHX_ ST(0));\r
- WCHAR wide_path[MAX_PATH+1];\r
- WCHAR *long_path;\r
-\r
- if (wcslen(wstr) < countof(wide_path)) {\r
- wcscpy(wide_path, wstr);\r
- long_path = my_longpathW(wide_path);\r
- if (long_path) {\r
- Safefree(wstr);\r
- ST(0) = wstr_to_sv(aTHX_ long_path);\r
- XSRETURN(1);\r
- }\r
- }\r
- Safefree(wstr);\r
- }\r
- else {\r
- SV *path;\r
- char tmpbuf[MAX_PATH+1];\r
- char *pathstr;\r
- STRLEN len;\r
-\r
- path = ST(0);\r
- pathstr = SvPV(path,len);\r
- if (len < sizeof(tmpbuf)) {\r
- strcpy(tmpbuf, pathstr);\r
- pathstr = my_longpathA(tmpbuf);\r
- if (pathstr) {\r
- ST(0) = sv_2mortal(newSVpvn(pathstr, strlen(pathstr)));\r
- XSRETURN(1);\r
- }\r
- }\r
- }\r
- XSRETURN_EMPTY;\r
-}\r
-\r
-XS(w32_GetANSIPathName)\r
-{\r
- dXSARGS;\r
- WCHAR *wide_path;\r
-\r
- if (items != 1)\r
- Perl_croak(aTHX_ "usage: Win32::GetANSIPathName($pathname)");\r
-\r
- wide_path = sv_to_wstr(aTHX_ ST(0));\r
- ST(0) = wstr_to_ansipath(aTHX_ wide_path);\r
- Safefree(wide_path);\r
- XSRETURN(1);\r
-}\r
-\r
-XS(w32_Sleep)\r
-{\r
- dXSARGS;\r
- if (items != 1)\r
- Perl_croak(aTHX_ "usage: Win32::Sleep($milliseconds)");\r
- Sleep((DWORD)SvIV(ST(0)));\r
- XSRETURN_YES;\r
-}\r
-\r
-XS(w32_CopyFile)\r
-{\r
- dXSARGS;\r
- BOOL bResult;\r
- char *pszSourceFile;\r
- char szSourceFile[MAX_PATH+1];\r
-\r
- if (items != 3)\r
- Perl_croak(aTHX_ "usage: Win32::CopyFile($from, $to, $overwrite)");\r
-\r
- pszSourceFile = PerlDir_mapA(SvPV_nolen(ST(0)));\r
- if (strlen(pszSourceFile) < sizeof(szSourceFile)) {\r
- strcpy(szSourceFile, pszSourceFile);\r
- bResult = CopyFileA(szSourceFile, PerlDir_mapA(SvPV_nolen(ST(1))), !SvTRUE(ST(2)));\r
- if (bResult)\r
- XSRETURN_YES;\r
- }\r
- XSRETURN_NO;\r
-}\r
-\r
-XS(w32_OutputDebugString)\r
-{\r
- dXSARGS;\r
- if (items != 1)\r
- Perl_croak(aTHX_ "usage: Win32::OutputDebugString($string)");\r
-\r
- if (SvUTF8(ST(0))) {\r
- WCHAR *str = sv_to_wstr(aTHX_ ST(0));\r
- OutputDebugStringW(str);\r
- Safefree(str);\r
- }\r
- else\r
- OutputDebugStringA(SvPV_nolen(ST(0)));\r
-\r
- XSRETURN_EMPTY;\r
-}\r
-\r
-XS(w32_GetCurrentProcessId)\r
-{\r
- dXSARGS;\r
- EXTEND(SP,1);\r
- XSRETURN_IV(GetCurrentProcessId());\r
-}\r
-\r
-XS(w32_GetCurrentThreadId)\r
-{\r
- dXSARGS;\r
- EXTEND(SP,1);\r
- XSRETURN_IV(GetCurrentThreadId());\r
-}\r
-\r
-XS(w32_CreateDirectory)\r
-{\r
- dXSARGS;\r
- BOOL result;\r
-\r
- if (items != 1)\r
- Perl_croak(aTHX_ "usage: Win32::CreateDirectory($dir)");\r
-\r
- if (IsWin2000() && SvUTF8(ST(0))) {\r
- WCHAR *dir = sv_to_wstr(aTHX_ ST(0));\r
- result = CreateDirectoryW(dir, NULL);\r
- Safefree(dir);\r
- }\r
- else {\r
- result = CreateDirectoryA(SvPV_nolen(ST(0)), NULL);\r
- }\r
-\r
- ST(0) = boolSV(result);\r
- XSRETURN(1);\r
-}\r
-\r
-XS(w32_CreateFile)\r
-{\r
- dXSARGS;\r
- HANDLE handle;\r
-\r
- if (items != 1)\r
- Perl_croak(aTHX_ "usage: Win32::CreateFile($file)");\r
-\r
- if (IsWin2000() && SvUTF8(ST(0))) {\r
- WCHAR *file = sv_to_wstr(aTHX_ ST(0));\r
- handle = CreateFileW(file, GENERIC_WRITE, FILE_SHARE_WRITE,\r
- NULL, CREATE_NEW, FILE_ATTRIBUTE_NORMAL, NULL);\r
- Safefree(file);\r
- }\r
- else {\r
- handle = CreateFileA(SvPV_nolen(ST(0)), GENERIC_WRITE, FILE_SHARE_WRITE,\r
- NULL, CREATE_NEW, FILE_ATTRIBUTE_NORMAL, NULL);\r
- }\r
-\r
- if (handle != INVALID_HANDLE_VALUE)\r
- CloseHandle(handle);\r
-\r
- ST(0) = boolSV(handle != INVALID_HANDLE_VALUE);\r
- XSRETURN(1);\r
-}\r
-\r
-XS(w32_GetSystemMetrics)\r
-{\r
- dXSARGS;\r
-\r
- if (items != 1)\r
- Perl_croak(aTHX_ "usage: Win32::GetSystemMetrics($index)");\r
-\r
- XSRETURN_IV(GetSystemMetrics((int)SvIV(ST(0))));\r
-}\r
-\r
-XS(w32_GetProductInfo)\r
-{\r
- dXSARGS;\r
- DWORD type;\r
- HMODULE module;\r
- PFNGetProductInfo pfnGetProductInfo;\r
-\r
- if (items != 4)\r
- Perl_croak(aTHX_ "usage: Win32::GetProductInfo($major,$minor,$spmajor,$spminor)");\r
-\r
- module = GetModuleHandle("kernel32.dll");\r
- GETPROC(GetProductInfo);\r
- if (pfnGetProductInfo &&\r
- pfnGetProductInfo((DWORD)SvIV(ST(0)), (DWORD)SvIV(ST(1)),\r
- (DWORD)SvIV(ST(2)), (DWORD)SvIV(ST(3)), &type))\r
- {\r
- XSRETURN_IV(type);\r
- }\r
-\r
- /* PRODUCT_UNDEFINED */\r
- XSRETURN_IV(0);\r
-}\r
-\r
-MODULE = Win32 PACKAGE = Win32\r
-\r
-PROTOTYPES: DISABLE\r
-\r
-BOOT:\r
-{\r
- char *file = __FILE__;\r
-\r
- if (g_osver.dwOSVersionInfoSize == 0) {\r
- g_osver.dwOSVersionInfoSize = sizeof(g_osver);\r
- if (!GetVersionExA((OSVERSIONINFOA*)&g_osver)) {\r
- g_osver_ex = FALSE;\r
- g_osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFOA);\r
- GetVersionExA((OSVERSIONINFOA*)&g_osver);\r
- }\r
- }\r
-\r
- newXS("Win32::LookupAccountName", w32_LookupAccountName, file);\r
- newXS("Win32::LookupAccountSID", w32_LookupAccountSID, file);\r
- newXS("Win32::InitiateSystemShutdown", w32_InitiateSystemShutdown, file);\r
- newXS("Win32::AbortSystemShutdown", w32_AbortSystemShutdown, file);\r
- newXS("Win32::ExpandEnvironmentStrings", w32_ExpandEnvironmentStrings, file);\r
- newXS("Win32::MsgBox", w32_MsgBox, file);\r
- newXS("Win32::LoadLibrary", w32_LoadLibrary, file);\r
- newXS("Win32::FreeLibrary", w32_FreeLibrary, file);\r
- newXS("Win32::GetProcAddress", w32_GetProcAddress, file);\r
- newXS("Win32::RegisterServer", w32_RegisterServer, file);\r
- newXS("Win32::UnregisterServer", w32_UnregisterServer, file);\r
- newXS("Win32::GetArchName", w32_GetArchName, file);\r
- newXS("Win32::GetChipName", w32_GetChipName, file);\r
- newXS("Win32::GuidGen", w32_GuidGen, file);\r
- newXS("Win32::GetFolderPath", w32_GetFolderPath, file);\r
- newXS("Win32::IsAdminUser", w32_IsAdminUser, file);\r
- newXS("Win32::GetFileVersion", w32_GetFileVersion, file);\r
-\r
- newXS("Win32::GetCwd", w32_GetCwd, file);\r
- newXS("Win32::SetCwd", w32_SetCwd, file);\r
- newXS("Win32::GetNextAvailDrive", w32_GetNextAvailDrive, file);\r
- newXS("Win32::GetLastError", w32_GetLastError, file);\r
- newXS("Win32::SetLastError", w32_SetLastError, file);\r
- newXS("Win32::LoginName", w32_LoginName, file);\r
- newXS("Win32::NodeName", w32_NodeName, file);\r
- newXS("Win32::DomainName", w32_DomainName, file);\r
- newXS("Win32::FsType", w32_FsType, file);\r
- newXS("Win32::GetOSVersion", w32_GetOSVersion, file);\r
- newXS("Win32::IsWinNT", w32_IsWinNT, file);\r
- newXS("Win32::IsWin95", w32_IsWin95, file);\r
- newXS("Win32::FormatMessage", w32_FormatMessage, file);\r
- newXS("Win32::Spawn", w32_Spawn, file);\r
- newXS("Win32::GetTickCount", w32_GetTickCount, file);\r
- newXS("Win32::GetShortPathName", w32_GetShortPathName, file);\r
- newXS("Win32::GetFullPathName", w32_GetFullPathName, file);\r
- newXS("Win32::GetLongPathName", w32_GetLongPathName, file);\r
- newXS("Win32::GetANSIPathName", w32_GetANSIPathName, file);\r
- newXS("Win32::CopyFile", w32_CopyFile, file);\r
- newXS("Win32::Sleep", w32_Sleep, file);\r
- newXS("Win32::OutputDebugString", w32_OutputDebugString, file);\r
- newXS("Win32::GetCurrentProcessId", w32_GetCurrentProcessId, file);\r
- newXS("Win32::GetCurrentThreadId", w32_GetCurrentThreadId, file);\r
- newXS("Win32::CreateDirectory", w32_CreateDirectory, file);\r
- newXS("Win32::CreateFile", w32_CreateFile, file);\r
- newXS("Win32::GetSystemMetrics", w32_GetSystemMetrics, file);\r
- newXS("Win32::GetProductInfo", w32_GetProductInfo, file);\r
-#ifdef __CYGWIN__\r
- newXS("Win32::SetChildShowWindow", w32_SetChildShowWindow, file);\r
-#endif\r
- XSRETURN_YES;\r
-}\r
+#define WIN32_LEAN_AND_MEAN
+#include <wctype.h>
+#include <windows.h>
+#include <shlobj.h>
+
+#define PERL_NO_GET_CONTEXT
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+#ifndef countof
+# define countof(array) (sizeof (array) / sizeof (*(array)))
+#endif
+
+#define SE_SHUTDOWN_NAMEA "SeShutdownPrivilege"
+
+#ifndef WC_NO_BEST_FIT_CHARS
+# define WC_NO_BEST_FIT_CHARS 0x00000400
+#endif
+
+#define GETPROC(fn) pfn##fn = (PFN##fn)GetProcAddress(module, #fn)
+
+typedef BOOL (WINAPI *PFNSHGetSpecialFolderPathA)(HWND, char*, int, BOOL);
+typedef BOOL (WINAPI *PFNSHGetSpecialFolderPathW)(HWND, WCHAR*, int, BOOL);
+typedef HRESULT (WINAPI *PFNSHGetFolderPathA)(HWND, int, HANDLE, DWORD, LPTSTR);
+typedef HRESULT (WINAPI *PFNSHGetFolderPathW)(HWND, int, HANDLE, DWORD, LPWSTR);
+typedef BOOL (WINAPI *PFNCreateEnvironmentBlock)(void**, HANDLE, BOOL);
+typedef BOOL (WINAPI *PFNDestroyEnvironmentBlock)(void*);
+typedef int (__stdcall *PFNDllRegisterServer)(void);
+typedef int (__stdcall *PFNDllUnregisterServer)(void);
+typedef DWORD (__stdcall *PFNNetApiBufferFree)(void*);
+typedef DWORD (__stdcall *PFNNetWkstaGetInfo)(LPWSTR, DWORD, void*);
+
+typedef BOOL (__stdcall *PFNOpenProcessToken)(HANDLE, DWORD, HANDLE*);
+typedef BOOL (__stdcall *PFNOpenThreadToken)(HANDLE, DWORD, BOOL, HANDLE*);
+typedef BOOL (__stdcall *PFNGetTokenInformation)(HANDLE, TOKEN_INFORMATION_CLASS, void*, DWORD, DWORD*);
+typedef BOOL (__stdcall *PFNAllocateAndInitializeSid)(PSID_IDENTIFIER_AUTHORITY, BYTE, DWORD, DWORD,
+ DWORD, DWORD, DWORD, DWORD, DWORD, DWORD, PSID*);
+typedef BOOL (__stdcall *PFNEqualSid)(PSID, PSID);
+typedef void* (__stdcall *PFNFreeSid)(PSID);
+typedef BOOL (__stdcall *PFNIsUserAnAdmin)(void);
+typedef BOOL (WINAPI *PFNGetProductInfo)(DWORD, DWORD, DWORD, DWORD, DWORD*);
+typedef void (WINAPI *PFNGetNativeSystemInfo)(LPSYSTEM_INFO lpSystemInfo);
+
+#ifndef CSIDL_MYMUSIC
+# define CSIDL_MYMUSIC 0x000D
+#endif
+#ifndef CSIDL_MYVIDEO
+# define CSIDL_MYVIDEO 0x000E
+#endif
+#ifndef CSIDL_LOCAL_APPDATA
+# define CSIDL_LOCAL_APPDATA 0x001C
+#endif
+#ifndef CSIDL_COMMON_FAVORITES
+# define CSIDL_COMMON_FAVORITES 0x001F
+#endif
+#ifndef CSIDL_INTERNET_CACHE
+# define CSIDL_INTERNET_CACHE 0x0020
+#endif
+#ifndef CSIDL_COOKIES
+# define CSIDL_COOKIES 0x0021
+#endif
+#ifndef CSIDL_HISTORY
+# define CSIDL_HISTORY 0x0022
+#endif
+#ifndef CSIDL_COMMON_APPDATA
+# define CSIDL_COMMON_APPDATA 0x0023
+#endif
+#ifndef CSIDL_WINDOWS
+# define CSIDL_WINDOWS 0x0024
+#endif
+#ifndef CSIDL_PROGRAM_FILES
+# define CSIDL_PROGRAM_FILES 0x0026
+#endif
+#ifndef CSIDL_MYPICTURES
+# define CSIDL_MYPICTURES 0x0027
+#endif
+#ifndef CSIDL_PROFILE
+# define CSIDL_PROFILE 0x0028
+#endif
+#ifndef CSIDL_PROGRAM_FILES_COMMON
+# define CSIDL_PROGRAM_FILES_COMMON 0x002B
+#endif
+#ifndef CSIDL_COMMON_TEMPLATES
+# define CSIDL_COMMON_TEMPLATES 0x002D
+#endif
+#ifndef CSIDL_COMMON_DOCUMENTS
+# define CSIDL_COMMON_DOCUMENTS 0x002E
+#endif
+#ifndef CSIDL_COMMON_ADMINTOOLS
+# define CSIDL_COMMON_ADMINTOOLS 0x002F
+#endif
+#ifndef CSIDL_ADMINTOOLS
+# define CSIDL_ADMINTOOLS 0x0030
+#endif
+#ifndef CSIDL_COMMON_MUSIC
+# define CSIDL_COMMON_MUSIC 0x0035
+#endif
+#ifndef CSIDL_COMMON_PICTURES
+# define CSIDL_COMMON_PICTURES 0x0036
+#endif
+#ifndef CSIDL_COMMON_VIDEO
+# define CSIDL_COMMON_VIDEO 0x0037
+#endif
+#ifndef CSIDL_CDBURN_AREA
+# define CSIDL_CDBURN_AREA 0x003B
+#endif
+#ifndef CSIDL_FLAG_CREATE
+# define CSIDL_FLAG_CREATE 0x8000
+#endif
+
+/* Use explicit struct definition because wSuiteMask and
+ * wProductType are not defined in the VC++ 6.0 headers.
+ * WORD type has been replaced by unsigned short because
+ * WORD is already used by Perl itself.
+ */
+struct {
+ DWORD dwOSVersionInfoSize;
+ DWORD dwMajorVersion;
+ DWORD dwMinorVersion;
+ DWORD dwBuildNumber;
+ DWORD dwPlatformId;
+ CHAR szCSDVersion[128];
+ unsigned short wServicePackMajor;
+ unsigned short wServicePackMinor;
+ unsigned short wSuiteMask;
+ BYTE wProductType;
+ BYTE wReserved;
+} g_osver = {0, 0, 0, 0, 0, "", 0, 0, 0, 0, 0};
+BOOL g_osver_ex = TRUE;
+
+#define ONE_K_BUFSIZE 1024
+
+int
+IsWin95(void)
+{
+ return (g_osver.dwPlatformId == VER_PLATFORM_WIN32_WINDOWS);
+}
+
+int
+IsWinNT(void)
+{
+ return (g_osver.dwPlatformId == VER_PLATFORM_WIN32_NT);
+}
+
+int
+IsWin2000(void)
+{
+ return (g_osver.dwMajorVersion > 4);
+}
+
+/* Convert SV to wide character string. The return value must be
+ * freed using Safefree().
+ */
+WCHAR*
+sv_to_wstr(pTHX_ SV *sv)
+{
+ DWORD wlen;
+ WCHAR *wstr;
+ STRLEN len;
+ char *str = SvPV(sv, len);
+ UINT cp = SvUTF8(sv) ? CP_UTF8 : CP_ACP;
+
+ wlen = MultiByteToWideChar(cp, 0, str, (int)(len+1), NULL, 0);
+ New(0, wstr, wlen, WCHAR);
+ MultiByteToWideChar(cp, 0, str, (int)(len+1), wstr, wlen);
+
+ return wstr;
+}
+
+/* Convert wide character string to mortal SV. Use UTF8 encoding
+ * if the string cannot be represented in the system codepage.
+ */
+SV *
+wstr_to_sv(pTHX_ WCHAR *wstr)
+{
+ int wlen = (int)wcslen(wstr)+1;
+ BOOL use_default = FALSE;
+ int len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, wstr, wlen, NULL, 0, NULL, NULL);
+ SV *sv = sv_2mortal(newSV(len));
+
+ len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, wstr, wlen, SvPVX(sv), len, NULL, &use_default);
+ if (use_default) {
+ len = WideCharToMultiByte(CP_UTF8, 0, wstr, wlen, NULL, 0, NULL, NULL);
+ sv_grow(sv, len);
+ len = WideCharToMultiByte(CP_UTF8, 0, wstr, wlen, SvPVX(sv), len, NULL, NULL);
+ SvUTF8_on(sv);
+ }
+ /* Shouldn't really ever fail since we ask for the required length first, but who knows... */
+ if (len) {
+ SvPOK_on(sv);
+ SvCUR_set(sv, len-1);
+ }
+ return sv;
+}
+
+/* Retrieve a variable from the Unicode environment in a mortal SV.
+ *
+ * Recreates the Unicode environment because a bug in earlier Perl versions
+ * overwrites it with the ANSI version, which contains replacement
+ * characters for the characters not in the ANSI codepage.
+ */
+SV*
+get_unicode_env(pTHX_ WCHAR *name)
+{
+ SV *sv = NULL;
+ void *env;
+ HANDLE token;
+ HMODULE module;
+ PFNOpenProcessToken pfnOpenProcessToken;
+
+ /* Get security token for the current process owner */
+ module = LoadLibrary("advapi32.dll");
+ if (!module)
+ return NULL;
+
+ GETPROC(OpenProcessToken);
+
+ if (pfnOpenProcessToken == NULL ||
+ !pfnOpenProcessToken(GetCurrentProcess(), TOKEN_QUERY | TOKEN_DUPLICATE, &token))
+ {
+ FreeLibrary(module);
+ return NULL;
+ }
+ FreeLibrary(module);
+
+ /* Create a Unicode environment block for this process */
+ module = LoadLibrary("userenv.dll");
+ if (module) {
+ PFNCreateEnvironmentBlock pfnCreateEnvironmentBlock;
+ PFNDestroyEnvironmentBlock pfnDestroyEnvironmentBlock;
+
+ GETPROC(CreateEnvironmentBlock);
+ GETPROC(DestroyEnvironmentBlock);
+
+ if (pfnCreateEnvironmentBlock && pfnDestroyEnvironmentBlock &&
+ pfnCreateEnvironmentBlock(&env, token, FALSE))
+ {
+ size_t name_len = wcslen(name);
+ WCHAR *entry = (WCHAR *)env;
+ while (*entry) {
+ size_t i;
+ size_t entry_len = wcslen(entry);
+ BOOL equal = (entry_len > name_len) && (entry[name_len] == '=');
+
+ for (i=0; equal && i < name_len; ++i)
+ equal = (towupper(entry[i]) == towupper(name[i]));
+
+ if (equal) {
+ sv = wstr_to_sv(aTHX_ entry+name_len+1);
+ break;
+ }
+ entry += entry_len+1;
+ }
+ pfnDestroyEnvironmentBlock(env);
+ }
+ FreeLibrary(module);
+ }
+ CloseHandle(token);
+ return sv;
+}
+
+/* Define both an ANSI and a Wide version of win32_longpath */
+
+#define CHAR_T char
+#define WIN32_FIND_DATA_T WIN32_FIND_DATAA
+#define FN_FINDFIRSTFILE FindFirstFileA
+#define FN_STRLEN strlen
+#define FN_STRCPY strcpy
+#define LONGPATH my_longpathA
+#include "longpath.inc"
+
+#define CHAR_T WCHAR
+#define WIN32_FIND_DATA_T WIN32_FIND_DATAW
+#define FN_FINDFIRSTFILE FindFirstFileW
+#define FN_STRLEN wcslen
+#define FN_STRCPY wcscpy
+#define LONGPATH my_longpathW
+#include "longpath.inc"
+
+/* The my_ansipath() function takes a Unicode filename and converts it
+ * into the current Windows codepage. If some characters cannot be mapped,
+ * then it will convert the short name instead.
+ *
+ * The buffer to the ansi pathname must be freed with Safefree() when it
+ * it no longer needed.
+ *
+ * The argument to my_ansipath() must exist before this function is
+ * called; otherwise there is no way to determine the short path name.
+ *
+ * Ideas for future refinement:
+ * - Only convert those segments of the path that are not in the current
+ * codepage, but leave the other segments in their long form.
+ * - If the resulting name is longer than MAX_PATH, start converting
+ * additional path segments into short names until the full name
+ * is shorter than MAX_PATH. Shorten the filename part last!
+ */
+
+/* This is a modified version of core Perl win32/win32.c(win32_ansipath).
+ * It uses New() etc. instead of win32_malloc().
+ */
+
+char *
+my_ansipath(const WCHAR *widename)
+{
+ char *name;
+ BOOL use_default = FALSE;
+ int widelen = (int)wcslen(widename)+1;
+ int len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, widename, widelen,
+ NULL, 0, NULL, NULL);
+ New(0, name, len, char);
+ WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, widename, widelen,
+ name, len, NULL, &use_default);
+ if (use_default) {
+ DWORD shortlen = GetShortPathNameW(widename, NULL, 0);
+ if (shortlen) {
+ WCHAR *shortname;
+ New(0, shortname, shortlen, WCHAR);
+ shortlen = GetShortPathNameW(widename, shortname, shortlen)+1;
+
+ len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, shortname, shortlen,
+ NULL, 0, NULL, NULL);
+ Renew(name, len, char);
+ WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, shortname, shortlen,
+ name, len, NULL, NULL);
+ Safefree(shortname);
+ }
+ }
+ return name;
+}
+
+/* Convert wide character path to ANSI path and return as mortal SV. */
+SV*
+wstr_to_ansipath(pTHX_ WCHAR *wstr)
+{
+ char *ansi = my_ansipath(wstr);
+ SV *sv = sv_2mortal(newSVpvn(ansi, strlen(ansi)));
+ Safefree(ansi);
+ return sv;
+}
+
+#ifdef __CYGWIN__
+
+char*
+get_childdir(void)
+{
+ dTHX;
+ char* ptr;
+
+ if (IsWin2000()) {
+ WCHAR filename[MAX_PATH+1];
+ GetCurrentDirectoryW(MAX_PATH+1, filename);
+ ptr = my_ansipath(filename);
+ }
+ else {
+ char filename[MAX_PATH+1];
+ GetCurrentDirectoryA(MAX_PATH+1, filename);
+ New(0, ptr, strlen(filename)+1, char);
+ strcpy(ptr, filename);
+ }
+ return ptr;
+}
+
+void
+free_childdir(char *d)
+{
+ dTHX;
+ Safefree(d);
+}
+
+void*
+get_childenv(void)
+{
+ return NULL;
+}
+
+void
+free_childenv(void *d)
+{
+}
+
+# define PerlDir_mapA(dir) (dir)
+
+#endif
+
+XS(w32_ExpandEnvironmentStrings)
+{
+ dXSARGS;
+
+ if (items != 1)
+ croak("usage: Win32::ExpandEnvironmentStrings($String);\n");
+
+ if (IsWin2000()) {
+ WCHAR value[31*1024];
+ WCHAR *source = sv_to_wstr(aTHX_ ST(0));
+ ExpandEnvironmentStringsW(source, value, countof(value)-1);
+ ST(0) = wstr_to_sv(aTHX_ value);
+ Safefree(source);
+ XSRETURN(1);
+ }
+ else {
+ char value[31*1024];
+ ExpandEnvironmentStringsA(SvPV_nolen(ST(0)), value, countof(value)-2);
+ XSRETURN_PV(value);
+ }
+}
+
+XS(w32_IsAdminUser)
+{
+ dXSARGS;
+ HMODULE module;
+ PFNIsUserAnAdmin pfnIsUserAnAdmin;
+ PFNOpenThreadToken pfnOpenThreadToken;
+ PFNOpenProcessToken pfnOpenProcessToken;
+ PFNGetTokenInformation pfnGetTokenInformation;
+ PFNAllocateAndInitializeSid pfnAllocateAndInitializeSid;
+ PFNEqualSid pfnEqualSid;
+ PFNFreeSid pfnFreeSid;
+ HANDLE hTok;
+ DWORD dwTokInfoLen;
+ TOKEN_GROUPS *lpTokInfo;
+ SID_IDENTIFIER_AUTHORITY NtAuth = SECURITY_NT_AUTHORITY;
+ PSID pAdminSid;
+ int iRetVal;
+ unsigned int i;
+
+ if (items)
+ croak("usage: Win32::IsAdminUser()");
+
+ /* There is no concept of "Administrator" user accounts on Win9x systems,
+ so just return true. */
+ if (IsWin95())
+ XSRETURN_YES;
+
+ /* Use IsUserAnAdmin() when available. On Vista this will only return TRUE
+ * if the process is running with elevated privileges and not just when the
+ * process owner is a member of the "Administrators" group.
+ */
+ module = LoadLibrary("shell32.dll");
+ if (module) {
+ GETPROC(IsUserAnAdmin);
+ if (pfnIsUserAnAdmin) {
+ EXTEND(SP, 1);
+ ST(0) = sv_2mortal(newSViv(pfnIsUserAnAdmin() ? 1 : 0));
+ FreeLibrary(module);
+ XSRETURN(1);
+ }
+ FreeLibrary(module);
+ }
+
+ module = LoadLibrary("advapi32.dll");
+ if (!module) {
+ warn("Cannot load advapi32.dll library");
+ XSRETURN_UNDEF;
+ }
+
+ GETPROC(OpenThreadToken);
+ GETPROC(OpenProcessToken);
+ GETPROC(GetTokenInformation);
+ GETPROC(AllocateAndInitializeSid);
+ GETPROC(EqualSid);
+ GETPROC(FreeSid);
+
+ if (!(pfnOpenThreadToken && pfnOpenProcessToken &&
+ pfnGetTokenInformation && pfnAllocateAndInitializeSid &&
+ pfnEqualSid && pfnFreeSid))
+ {
+ warn("Cannot load functions from advapi32.dll library");
+ FreeLibrary(module);
+ XSRETURN_UNDEF;
+ }
+
+ if (!pfnOpenThreadToken(GetCurrentThread(), TOKEN_QUERY, FALSE, &hTok)) {
+ if (!pfnOpenProcessToken(GetCurrentProcess(), TOKEN_QUERY, &hTok)) {
+ warn("Cannot open thread token or process token");
+ FreeLibrary(module);
+ XSRETURN_UNDEF;
+ }
+ }
+
+ pfnGetTokenInformation(hTok, TokenGroups, NULL, 0, &dwTokInfoLen);
+ if (!New(1, lpTokInfo, dwTokInfoLen, TOKEN_GROUPS)) {
+ warn("Cannot allocate token information structure");
+ CloseHandle(hTok);
+ FreeLibrary(module);
+ XSRETURN_UNDEF;
+ }
+
+ if (!pfnGetTokenInformation(hTok, TokenGroups, lpTokInfo, dwTokInfoLen,
+ &dwTokInfoLen))
+ {
+ warn("Cannot get token information");
+ Safefree(lpTokInfo);
+ CloseHandle(hTok);
+ FreeLibrary(module);
+ XSRETURN_UNDEF;
+ }
+
+ if (!pfnAllocateAndInitializeSid(&NtAuth, 2, SECURITY_BUILTIN_DOMAIN_RID,
+ DOMAIN_ALIAS_RID_ADMINS, 0, 0, 0, 0, 0, 0, &pAdminSid))
+ {
+ warn("Cannot allocate administrators' SID");
+ Safefree(lpTokInfo);
+ CloseHandle(hTok);
+ FreeLibrary(module);
+ XSRETURN_UNDEF;
+ }
+
+ iRetVal = 0;
+ for (i = 0; i < lpTokInfo->GroupCount; ++i) {
+ if (pfnEqualSid(lpTokInfo->Groups[i].Sid, pAdminSid)) {
+ iRetVal = 1;
+ break;
+ }
+ }
+
+ pfnFreeSid(pAdminSid);
+ Safefree(lpTokInfo);
+ CloseHandle(hTok);
+ FreeLibrary(module);
+
+ EXTEND(SP, 1);
+ ST(0) = sv_2mortal(newSViv(iRetVal));
+ XSRETURN(1);
+}
+
+XS(w32_LookupAccountName)
+{
+ dXSARGS;
+ char SID[400];
+ DWORD SIDLen;
+ SID_NAME_USE snu;
+ char Domain[256];
+ DWORD DomLen;
+ BOOL bResult;
+
+ if (items != 5)
+ croak("usage: Win32::LookupAccountName($system, $account, $domain, "
+ "$sid, $sidtype);\n");
+
+ SIDLen = sizeof(SID);
+ DomLen = sizeof(Domain);
+
+ bResult = LookupAccountNameA(SvPV_nolen(ST(0)), /* System */
+ SvPV_nolen(ST(1)), /* Account name */
+ &SID, /* SID structure */
+ &SIDLen, /* Size of SID buffer */
+ Domain, /* Domain buffer */
+ &DomLen, /* Domain buffer size */
+ &snu); /* SID name type */
+ if (bResult) {
+ sv_setpv(ST(2), Domain);
+ sv_setpvn(ST(3), SID, SIDLen);
+ sv_setiv(ST(4), snu);
+ XSRETURN_YES;
+ }
+ XSRETURN_NO;
+}
+
+
+XS(w32_LookupAccountSID)
+{
+ dXSARGS;
+ PSID sid;
+ char Account[256];
+ DWORD AcctLen = sizeof(Account);
+ char Domain[256];
+ DWORD DomLen = sizeof(Domain);
+ SID_NAME_USE snu;
+ BOOL bResult;
+
+ if (items != 5)
+ croak("usage: Win32::LookupAccountSID($system, $sid, $account, $domain, $sidtype);\n");
+
+ sid = SvPV_nolen(ST(1));
+ if (IsValidSid(sid)) {
+ bResult = LookupAccountSidA(SvPV_nolen(ST(0)), /* System */
+ sid, /* SID structure */
+ Account, /* Account name buffer */
+ &AcctLen, /* name buffer length */
+ Domain, /* Domain buffer */
+ &DomLen, /* Domain buffer length */
+ &snu); /* SID name type */
+ if (bResult) {
+ sv_setpv(ST(2), Account);
+ sv_setpv(ST(3), Domain);
+ sv_setiv(ST(4), (IV)snu);
+ XSRETURN_YES;
+ }
+ }
+ XSRETURN_NO;
+}
+
+XS(w32_InitiateSystemShutdown)
+{
+ dXSARGS;
+ HANDLE hToken; /* handle to process token */
+ TOKEN_PRIVILEGES tkp; /* pointer to token structure */
+ BOOL bRet;
+ char *machineName, *message;
+
+ if (items != 5)
+ croak("usage: Win32::InitiateSystemShutdown($machineName, $message, "
+ "$timeOut, $forceClose, $reboot);\n");
+
+ machineName = SvPV_nolen(ST(0));
+
+ if (OpenProcessToken(GetCurrentProcess(),
+ TOKEN_ADJUST_PRIVILEGES | TOKEN_QUERY,
+ &hToken))
+ {
+ LookupPrivilegeValueA(machineName,
+ SE_SHUTDOWN_NAMEA,
+ &tkp.Privileges[0].Luid);
+
+ tkp.PrivilegeCount = 1; /* only setting one */
+ tkp.Privileges[0].Attributes = SE_PRIVILEGE_ENABLED;
+
+ /* Get shutdown privilege for this process. */
+ AdjustTokenPrivileges(hToken, FALSE, &tkp, 0,
+ (PTOKEN_PRIVILEGES)NULL, 0);
+ }
+
+ message = SvPV_nolen(ST(1));
+ bRet = InitiateSystemShutdownA(machineName, message, (DWORD)SvIV(ST(2)),
+ (BOOL)SvIV(ST(3)), (BOOL)SvIV(ST(4)));
+
+ /* Disable shutdown privilege. */
+ tkp.Privileges[0].Attributes = 0;
+ AdjustTokenPrivileges(hToken, FALSE, &tkp, 0,
+ (PTOKEN_PRIVILEGES)NULL, 0);
+ CloseHandle(hToken);
+ XSRETURN_IV(bRet);
+}
+
+XS(w32_AbortSystemShutdown)
+{
+ dXSARGS;
+ HANDLE hToken; /* handle to process token */
+ TOKEN_PRIVILEGES tkp; /* pointer to token structure */
+ BOOL bRet;
+ char *machineName;
+
+ if (items != 1)
+ croak("usage: Win32::AbortSystemShutdown($machineName);\n");
+
+ machineName = SvPV_nolen(ST(0));
+
+ if (OpenProcessToken(GetCurrentProcess(),
+ TOKEN_ADJUST_PRIVILEGES | TOKEN_QUERY,
+ &hToken))
+ {
+ LookupPrivilegeValueA(machineName,
+ SE_SHUTDOWN_NAMEA,
+ &tkp.Privileges[0].Luid);
+
+ tkp.PrivilegeCount = 1; /* only setting one */
+ tkp.Privileges[0].Attributes = SE_PRIVILEGE_ENABLED;
+
+ /* Get shutdown privilege for this process. */
+ AdjustTokenPrivileges(hToken, FALSE, &tkp, 0,
+ (PTOKEN_PRIVILEGES)NULL, 0);
+ }
+
+ bRet = AbortSystemShutdownA(machineName);
+
+ /* Disable shutdown privilege. */
+ tkp.Privileges[0].Attributes = 0;
+ AdjustTokenPrivileges(hToken, FALSE, &tkp, 0,
+ (PTOKEN_PRIVILEGES)NULL, 0);
+ CloseHandle(hToken);
+ XSRETURN_IV(bRet);
+}
+
+
+XS(w32_MsgBox)
+{
+ dXSARGS;
+ DWORD flags = MB_ICONEXCLAMATION;
+ I32 result;
+
+ if (items < 1 || items > 3)
+ croak("usage: Win32::MsgBox($message [, $flags [, $title]]);\n");
+
+ if (items > 1)
+ flags = (DWORD)SvIV(ST(1));
+
+ if (IsWin2000()) {
+ WCHAR *title = NULL;
+ WCHAR *msg = sv_to_wstr(aTHX_ ST(0));
+ if (items > 2)
+ title = sv_to_wstr(aTHX_ ST(2));
+ result = MessageBoxW(GetActiveWindow(), msg, title ? title : L"Perl", flags);
+ Safefree(msg);
+ if (title)
+ Safefree(title);
+ }
+ else {
+ char *title = "Perl";
+ char *msg = SvPV_nolen(ST(0));
+ if (items > 2)
+ title = SvPV_nolen(ST(2));
+ result = MessageBoxA(GetActiveWindow(), msg, title, flags);
+ }
+ XSRETURN_IV(result);
+}
+
+XS(w32_LoadLibrary)
+{
+ dXSARGS;
+ HANDLE hHandle;
+
+ if (items != 1)
+ croak("usage: Win32::LoadLibrary($libname)\n");
+ hHandle = LoadLibraryA(SvPV_nolen(ST(0)));
+#ifdef _WIN64
+ XSRETURN_IV((DWORD_PTR)hHandle);
+#else
+ XSRETURN_IV((DWORD)hHandle);
+#endif
+}
+
+XS(w32_FreeLibrary)
+{
+ dXSARGS;
+
+ if (items != 1)
+ croak("usage: Win32::FreeLibrary($handle)\n");
+ if (FreeLibrary(INT2PTR(HINSTANCE, SvIV(ST(0))))) {
+ XSRETURN_YES;
+ }
+ XSRETURN_NO;
+}
+
+XS(w32_GetProcAddress)
+{
+ dXSARGS;
+
+ if (items != 2)
+ croak("usage: Win32::GetProcAddress($hinstance, $procname)\n");
+ XSRETURN_IV(PTR2IV(GetProcAddress(INT2PTR(HINSTANCE, SvIV(ST(0))), SvPV_nolen(ST(1)))));
+}
+
+XS(w32_RegisterServer)
+{
+ dXSARGS;
+ BOOL result = FALSE;
+ HMODULE module;
+
+ if (items != 1)
+ croak("usage: Win32::RegisterServer($libname)\n");
+
+ module = LoadLibraryA(SvPV_nolen(ST(0)));
+ if (module) {
+ PFNDllRegisterServer pfnDllRegisterServer;
+ GETPROC(DllRegisterServer);
+ if (pfnDllRegisterServer && pfnDllRegisterServer() == 0)
+ result = TRUE;
+ FreeLibrary(module);
+ }
+ ST(0) = boolSV(result);
+ XSRETURN(1);
+}
+
+XS(w32_UnregisterServer)
+{
+ dXSARGS;
+ BOOL result = FALSE;
+ HINSTANCE module;
+
+ if (items != 1)
+ croak("usage: Win32::UnregisterServer($libname)\n");
+
+ module = LoadLibraryA(SvPV_nolen(ST(0)));
+ if (module) {
+ PFNDllUnregisterServer pfnDllUnregisterServer;
+ GETPROC(DllUnregisterServer);
+ if (pfnDllUnregisterServer && pfnDllUnregisterServer() == 0)
+ result = TRUE;
+ FreeLibrary(module);
+ }
+ ST(0) = boolSV(result);
+ XSRETURN(1);
+}
+
+/* XXX rather bogus */
+XS(w32_GetArchName)
+{
+ dXSARGS;
+ XSRETURN_PV(getenv("PROCESSOR_ARCHITECTURE"));
+}
+
+XS(w32_GetChipName)
+{
+ dXSARGS;
+ SYSTEM_INFO sysinfo;
+ HMODULE module;
+ PFNGetNativeSystemInfo pfnGetNativeSystemInfo;
+
+ Zero(&sysinfo,1,SYSTEM_INFO);
+ module = GetModuleHandle("kernel32.dll");
+ GETPROC(GetNativeSystemInfo);
+ if (pfnGetNativeSystemInfo)
+ pfnGetNativeSystemInfo(&sysinfo);
+ else
+ GetSystemInfo(&sysinfo);
+
+ /* XXX docs say dwProcessorType is deprecated on NT */
+ XSRETURN_IV(sysinfo.dwProcessorType);
+}
+
+XS(w32_GuidGen)
+{
+ dXSARGS;
+ GUID guid;
+ char szGUID[50] = {'\0'};
+ HRESULT hr = CoCreateGuid(&guid);
+
+ if (SUCCEEDED(hr)) {
+ LPOLESTR pStr = NULL;
+#ifdef __cplusplus
+ if (SUCCEEDED(StringFromCLSID(guid, &pStr))) {
+#else
+ if (SUCCEEDED(StringFromCLSID(&guid, &pStr))) {
+#endif
+ WideCharToMultiByte(CP_ACP, 0, pStr, (int)wcslen(pStr), szGUID,
+ sizeof(szGUID), NULL, NULL);
+ CoTaskMemFree(pStr);
+ XSRETURN_PV(szGUID);
+ }
+ }
+ XSRETURN_UNDEF;
+}
+
+XS(w32_GetFolderPath)
+{
+ dXSARGS;
+ char path[MAX_PATH+1];
+ WCHAR wpath[MAX_PATH+1];
+ int folder;
+ int create = 0;
+ HMODULE module;
+
+ if (items != 1 && items != 2)
+ croak("usage: Win32::GetFolderPath($csidl [, $create])\n");
+
+ folder = (int)SvIV(ST(0));
+ if (items == 2)
+ create = SvTRUE(ST(1)) ? CSIDL_FLAG_CREATE : 0;
+
+ module = LoadLibrary("shfolder.dll");
+ if (module) {
+ PFNSHGetFolderPathA pfna;
+ if (IsWin2000()) {
+ PFNSHGetFolderPathW pfnw;
+ pfnw = (PFNSHGetFolderPathW)GetProcAddress(module, "SHGetFolderPathW");
+ if (pfnw && SUCCEEDED(pfnw(NULL, folder|create, NULL, 0, wpath))) {
+ FreeLibrary(module);
+ ST(0) = wstr_to_ansipath(aTHX_ wpath);
+ XSRETURN(1);
+ }
+ }
+ pfna = (PFNSHGetFolderPathA)GetProcAddress(module, "SHGetFolderPathA");
+ if (pfna && SUCCEEDED(pfna(NULL, folder|create, NULL, 0, path))) {
+ FreeLibrary(module);
+ XSRETURN_PV(path);
+ }
+ FreeLibrary(module);
+ }
+
+ module = LoadLibrary("shell32.dll");
+ if (module) {
+ PFNSHGetSpecialFolderPathA pfna;
+ if (IsWin2000()) {
+ PFNSHGetSpecialFolderPathW pfnw;
+ pfnw = (PFNSHGetSpecialFolderPathW)GetProcAddress(module, "SHGetSpecialFolderPathW");
+ if (pfnw && pfnw(NULL, wpath, folder, !!create)) {
+ FreeLibrary(module);
+ ST(0) = wstr_to_ansipath(aTHX_ wpath);
+ XSRETURN(1);
+ }
+ }
+ pfna = (PFNSHGetSpecialFolderPathA)GetProcAddress(module, "SHGetSpecialFolderPathA");
+ if (pfna && pfna(NULL, path, folder, !!create)) {
+ FreeLibrary(module);
+ XSRETURN_PV(path);
+ }
+ FreeLibrary(module);
+ }
+
+ /* SHGetFolderPathW() and SHGetSpecialFolderPathW() may fail on older
+ * Perl versions that have replaced the Unicode environment with an
+ * ANSI version. Let's go spelunking in the registry now...
+ */
+ if (IsWin2000()) {
+ SV *sv;
+ HKEY hkey;
+ HKEY root = HKEY_CURRENT_USER;
+ WCHAR *name = NULL;
+
+ switch (folder) {
+ case CSIDL_ADMINTOOLS: name = L"Administrative Tools"; break;
+ case CSIDL_APPDATA: name = L"AppData"; break;
+ case CSIDL_CDBURN_AREA: name = L"CD Burning"; break;
+ case CSIDL_COOKIES: name = L"Cookies"; break;
+ case CSIDL_DESKTOP:
+ case CSIDL_DESKTOPDIRECTORY: name = L"Desktop"; break;
+ case CSIDL_FAVORITES: name = L"Favorites"; break;
+ case CSIDL_FONTS: name = L"Fonts"; break;
+ case CSIDL_HISTORY: name = L"History"; break;
+ case CSIDL_INTERNET_CACHE: name = L"Cache"; break;
+ case CSIDL_LOCAL_APPDATA: name = L"Local AppData"; break;
+ case CSIDL_MYMUSIC: name = L"My Music"; break;
+ case CSIDL_MYPICTURES: name = L"My Pictures"; break;
+ case CSIDL_MYVIDEO: name = L"My Video"; break;
+ case CSIDL_NETHOOD: name = L"NetHood"; break;
+ case CSIDL_PERSONAL: name = L"Personal"; break;
+ case CSIDL_PRINTHOOD: name = L"PrintHood"; break;
+ case CSIDL_PROGRAMS: name = L"Programs"; break;
+ case CSIDL_RECENT: name = L"Recent"; break;
+ case CSIDL_SENDTO: name = L"SendTo"; break;
+ case CSIDL_STARTMENU: name = L"Start Menu"; break;
+ case CSIDL_STARTUP: name = L"Startup"; break;
+ case CSIDL_TEMPLATES: name = L"Templates"; break;
+ /* XXX L"Local Settings" */
+ }
+
+ if (!name) {
+ root = HKEY_LOCAL_MACHINE;
+ switch (folder) {
+ case CSIDL_COMMON_ADMINTOOLS: name = L"Common Administrative Tools"; break;
+ case CSIDL_COMMON_APPDATA: name = L"Common AppData"; break;
+ case CSIDL_COMMON_DESKTOPDIRECTORY: name = L"Common Desktop"; break;
+ case CSIDL_COMMON_DOCUMENTS: name = L"Common Documents"; break;
+ case CSIDL_COMMON_FAVORITES: name = L"Common Favorites"; break;
+ case CSIDL_COMMON_PROGRAMS: name = L"Common Programs"; break;
+ case CSIDL_COMMON_STARTMENU: name = L"Common Start Menu"; break;
+ case CSIDL_COMMON_STARTUP: name = L"Common Startup"; break;
+ case CSIDL_COMMON_TEMPLATES: name = L"Common Templates"; break;
+ case CSIDL_COMMON_MUSIC: name = L"CommonMusic"; break;
+ case CSIDL_COMMON_PICTURES: name = L"CommonPictures"; break;
+ case CSIDL_COMMON_VIDEO: name = L"CommonVideo"; break;
+ }
+ }
+ /* XXX todo
+ * case CSIDL_SYSTEM # GetSystemDirectory()
+ * case CSIDL_RESOURCES # %windir%\Resources\, For theme and other windows resources.
+ * case CSIDL_RESOURCES_LOCALIZED # %windir%\Resources\<LangID>, for theme and other windows specific resources.
+ */
+
+#define SHELL_FOLDERS "Software\\Microsoft\\Windows\\CurrentVersion\\Explorer\\Shell Folders"
+
+ if (name && RegOpenKeyEx(root, SHELL_FOLDERS, 0, KEY_QUERY_VALUE, &hkey) == ERROR_SUCCESS) {
+ WCHAR data[MAX_PATH+1];
+ DWORD cb = sizeof(data)-sizeof(WCHAR);
+ DWORD type = REG_NONE;
+ long rc = RegQueryValueExW(hkey, name, NULL, &type, (BYTE*)&data, &cb);
+ RegCloseKey(hkey);
+ if (rc == ERROR_SUCCESS && type == REG_SZ && cb > sizeof(WCHAR) && data[0]) {
+ /* Make sure the string is properly terminated */
+ data[cb/sizeof(WCHAR)] = '\0';
+ ST(0) = wstr_to_ansipath(aTHX_ data);
+ XSRETURN(1);
+ }
+ }
+
+#undef SHELL_FOLDERS
+
+ /* Unders some circumstances the registry entries seem to have a null string
+ * as their value even when the directory already exists. The environment
+ * variables do get set though, so try re-create a Unicode environment and
+ * check if they are there.
+ */
+ sv = NULL;
+ switch (folder) {
+ case CSIDL_APPDATA: sv = get_unicode_env(aTHX_ L"APPDATA"); break;
+ case CSIDL_PROFILE: sv = get_unicode_env(aTHX_ L"USERPROFILE"); break;
+ case CSIDL_PROGRAM_FILES: sv = get_unicode_env(aTHX_ L"ProgramFiles"); break;
+ case CSIDL_PROGRAM_FILES_COMMON: sv = get_unicode_env(aTHX_ L"CommonProgramFiles"); break;
+ case CSIDL_WINDOWS: sv = get_unicode_env(aTHX_ L"SystemRoot"); break;
+ }
+ if (sv) {
+ ST(0) = sv;
+ XSRETURN(1);
+ }
+ }
+
+ XSRETURN_UNDEF;
+}
+
+XS(w32_GetFileVersion)
+{
+ dXSARGS;
+ DWORD size;
+ DWORD handle;
+ char *filename;
+ char *data;
+
+ if (items != 1)
+ croak("usage: Win32::GetFileVersion($filename)\n");
+
+ filename = SvPV_nolen(ST(0));
+ size = GetFileVersionInfoSize(filename, &handle);
+ if (!size)
+ XSRETURN_UNDEF;
+
+ New(0, data, size, char);
+ if (!data)
+ XSRETURN_UNDEF;
+
+ if (GetFileVersionInfo(filename, handle, size, data)) {
+ VS_FIXEDFILEINFO *info;
+ UINT len;
+ if (VerQueryValue(data, "\\", (void**)&info, &len)) {
+ int dwValueMS1 = (info->dwFileVersionMS>>16);
+ int dwValueMS2 = (info->dwFileVersionMS&0xffff);
+ int dwValueLS1 = (info->dwFileVersionLS>>16);
+ int dwValueLS2 = (info->dwFileVersionLS&0xffff);
+
+ if (GIMME_V == G_ARRAY) {
+ EXTEND(SP, 4);
+ XST_mIV(0, dwValueMS1);
+ XST_mIV(1, dwValueMS2);
+ XST_mIV(2, dwValueLS1);
+ XST_mIV(3, dwValueLS2);
+ items = 4;
+ }
+ else {
+ char version[50];
+ sprintf(version, "%d.%d.%d.%d", dwValueMS1, dwValueMS2, dwValueLS1, dwValueLS2);
+ XST_mPV(0, version);
+ }
+ }
+ }
+ else
+ items = 0;
+
+ Safefree(data);
+ XSRETURN(items);
+}
+
+#ifdef __CYGWIN__
+XS(w32_SetChildShowWindow)
+{
+ /* This function doesn't do anything useful for cygwin. In the
+ * MSWin32 case it modifies w32_showwindow, which is used by
+ * win32_spawnvp(). Since w32_showwindow is an internal variable
+ * inside the thread_intern structure, the MSWin32 implementation
+ * lives in win32/win32.c in the core Perl distribution.
+ */
+ dXSARGS;
+ XSRETURN_UNDEF;
+}
+#endif
+
+XS(w32_GetCwd)
+{
+ dXSARGS;
+ /* Make the host for current directory */
+ char* ptr = PerlEnv_get_childdir();
+ /*
+ * If ptr != Nullch
+ * then it worked, set PV valid,
+ * else return 'undef'
+ */
+ if (ptr) {
+ SV *sv = sv_newmortal();
+ sv_setpv(sv, ptr);
+ PerlEnv_free_childdir(ptr);
+
+#ifndef INCOMPLETE_TAINTS
+ SvTAINTED_on(sv);
+#endif
+
+ EXTEND(SP,1);
+ ST(0) = sv;
+ XSRETURN(1);
+ }
+ XSRETURN_UNDEF;
+}
+
+XS(w32_SetCwd)
+{
+ dXSARGS;
+ if (items != 1)
+ Perl_croak(aTHX_ "usage: Win32::SetCwd($cwd)");
+
+ if (IsWin2000() && SvUTF8(ST(0))) {
+ WCHAR *wide = sv_to_wstr(aTHX_ ST(0));
+ char *ansi = my_ansipath(wide);
+ int rc = PerlDir_chdir(ansi);
+ Safefree(wide);
+ Safefree(ansi);
+ if (!rc)
+ XSRETURN_YES;
+ }
+ else {
+ if (!PerlDir_chdir(SvPV_nolen(ST(0))))
+ XSRETURN_YES;
+ }
+
+ XSRETURN_NO;
+}
+
+XS(w32_GetNextAvailDrive)
+{
+ dXSARGS;
+ char ix = 'C';
+ char root[] = "_:\\";
+
+ EXTEND(SP,1);
+ while (ix <= 'Z') {
+ root[0] = ix++;
+ if (GetDriveType(root) == 1) {
+ root[2] = '\0';
+ XSRETURN_PV(root);
+ }
+ }
+ XSRETURN_UNDEF;
+}
+
+XS(w32_GetLastError)
+{
+ dXSARGS;
+ EXTEND(SP,1);
+ XSRETURN_IV(GetLastError());
+}
+
+XS(w32_SetLastError)
+{
+ dXSARGS;
+ if (items != 1)
+ Perl_croak(aTHX_ "usage: Win32::SetLastError($error)");
+ SetLastError((DWORD)SvIV(ST(0)));
+ XSRETURN_EMPTY;
+}
+
+XS(w32_LoginName)
+{
+ dXSARGS;
+ EXTEND(SP,1);
+ if (IsWin2000()) {
+ WCHAR name[128];
+ DWORD size = countof(name);
+ if (GetUserNameW(name, &size)) {
+ ST(0) = wstr_to_sv(aTHX_ name);
+ XSRETURN(1);
+ }
+ }
+ else {
+ char name[128];
+ DWORD size = countof(name);
+ if (GetUserNameA(name, &size)) {
+ /* size includes NULL */
+ ST(0) = sv_2mortal(newSVpvn(name, size-1));
+ XSRETURN(1);
+ }
+ }
+ XSRETURN_UNDEF;
+}
+
+XS(w32_NodeName)
+{
+ dXSARGS;
+ char name[MAX_COMPUTERNAME_LENGTH+1];
+ DWORD size = sizeof(name);
+ EXTEND(SP,1);
+ if (GetComputerName(name,&size)) {
+ /* size does NOT include NULL :-( */
+ ST(0) = sv_2mortal(newSVpvn(name,size));
+ XSRETURN(1);
+ }
+ XSRETURN_UNDEF;
+}
+
+
+XS(w32_DomainName)
+{
+ dXSARGS;
+ HMODULE module = LoadLibrary("netapi32.dll");
+ PFNNetApiBufferFree pfnNetApiBufferFree;
+ PFNNetWkstaGetInfo pfnNetWkstaGetInfo;
+
+ if (module) {
+ GETPROC(NetApiBufferFree);
+ GETPROC(NetWkstaGetInfo);
+ }
+ EXTEND(SP,1);
+ if (module && pfnNetWkstaGetInfo && pfnNetApiBufferFree) {
+ /* this way is more reliable, in case user has a local account. */
+ char dname[256];
+ DWORD dnamelen = sizeof(dname);
+ struct {
+ DWORD wki100_platform_id;
+ LPWSTR wki100_computername;
+ LPWSTR wki100_langroup;
+ DWORD wki100_ver_major;
+ DWORD wki100_ver_minor;
+ } *pwi;
+ DWORD retval;
+ retval = pfnNetWkstaGetInfo(NULL, 100, &pwi);
+ /* NERR_Success *is* 0*/
+ if (retval == 0) {
+ if (pwi->wki100_langroup && *(pwi->wki100_langroup)) {
+ WideCharToMultiByte(CP_ACP, 0, pwi->wki100_langroup,
+ -1, (LPSTR)dname, dnamelen, NULL, NULL);
+ }
+ else {
+ WideCharToMultiByte(CP_ACP, 0, pwi->wki100_computername,
+ -1, (LPSTR)dname, dnamelen, NULL, NULL);
+ }
+ pfnNetApiBufferFree(pwi);
+ FreeLibrary(module);
+ XSRETURN_PV(dname);
+ }
+ FreeLibrary(module);
+ SetLastError(retval);
+ }
+ else {
+ /* Win95 doesn't have NetWksta*(), so do it the old way */
+ char name[256];
+ DWORD size = sizeof(name);
+ if (module)
+ FreeLibrary(module);
+ if (GetUserName(name,&size)) {
+ char sid[ONE_K_BUFSIZE];
+ DWORD sidlen = sizeof(sid);
+ char dname[256];
+ DWORD dnamelen = sizeof(dname);
+ SID_NAME_USE snu;
+ if (LookupAccountName(NULL, name, (PSID)&sid, &sidlen,
+ dname, &dnamelen, &snu)) {
+ XSRETURN_PV(dname); /* all that for this */
+ }
+ }
+ }
+ XSRETURN_UNDEF;
+}
+
+XS(w32_FsType)
+{
+ dXSARGS;
+ char fsname[256];
+ DWORD flags, filecomplen;
+ if (GetVolumeInformation(NULL, NULL, 0, NULL, &filecomplen,
+ &flags, fsname, sizeof(fsname))) {
+ if (GIMME_V == G_ARRAY) {
+ XPUSHs(sv_2mortal(newSVpvn(fsname,strlen(fsname))));
+ XPUSHs(sv_2mortal(newSViv(flags)));
+ XPUSHs(sv_2mortal(newSViv(filecomplen)));
+ PUTBACK;
+ return;
+ }
+ EXTEND(SP,1);
+ XSRETURN_PV(fsname);
+ }
+ XSRETURN_EMPTY;
+}
+
+XS(w32_GetOSVersion)
+{
+ dXSARGS;
+
+ if (GIMME_V == G_SCALAR) {
+ XSRETURN_IV(g_osver.dwPlatformId);
+ }
+ XPUSHs(sv_2mortal(newSVpvn(g_osver.szCSDVersion, strlen(g_osver.szCSDVersion))));
+
+ XPUSHs(sv_2mortal(newSViv(g_osver.dwMajorVersion)));
+ XPUSHs(sv_2mortal(newSViv(g_osver.dwMinorVersion)));
+ XPUSHs(sv_2mortal(newSViv(g_osver.dwBuildNumber)));
+ XPUSHs(sv_2mortal(newSViv(g_osver.dwPlatformId)));
+ if (g_osver_ex) {
+ XPUSHs(sv_2mortal(newSViv(g_osver.wServicePackMajor)));
+ XPUSHs(sv_2mortal(newSViv(g_osver.wServicePackMinor)));
+ XPUSHs(sv_2mortal(newSViv(g_osver.wSuiteMask)));
+ XPUSHs(sv_2mortal(newSViv(g_osver.wProductType)));
+ }
+ PUTBACK;
+}
+
+XS(w32_IsWinNT)
+{
+ dXSARGS;
+ EXTEND(SP,1);
+ XSRETURN_IV(IsWinNT());
+}
+
+XS(w32_IsWin95)
+{
+ dXSARGS;
+ EXTEND(SP,1);
+ XSRETURN_IV(IsWin95());
+}
+
+XS(w32_FormatMessage)
+{
+ dXSARGS;
+ DWORD source = 0;
+ char msgbuf[ONE_K_BUFSIZE];
+
+ if (items != 1)
+ Perl_croak(aTHX_ "usage: Win32::FormatMessage($errno)");
+
+ if (FormatMessageA(FORMAT_MESSAGE_FROM_SYSTEM,
+ &source, (DWORD)SvIV(ST(0)), 0,
+ msgbuf, sizeof(msgbuf)-1, NULL))
+ {
+ XSRETURN_PV(msgbuf);
+ }
+
+ XSRETURN_UNDEF;
+}
+
+XS(w32_Spawn)
+{
+ dXSARGS;
+ char *cmd, *args;
+ void *env;
+ char *dir;
+ PROCESS_INFORMATION stProcInfo;
+ STARTUPINFO stStartInfo;
+ BOOL bSuccess = FALSE;
+
+ if (items != 3)
+ Perl_croak(aTHX_ "usage: Win32::Spawn($cmdName, $args, $PID)");
+
+ cmd = SvPV_nolen(ST(0));
+ args = SvPV_nolen(ST(1));
+
+ env = PerlEnv_get_childenv();
+ dir = PerlEnv_get_childdir();
+
+ memset(&stStartInfo, 0, sizeof(stStartInfo)); /* Clear the block */
+ stStartInfo.cb = sizeof(stStartInfo); /* Set the structure size */
+ stStartInfo.dwFlags = STARTF_USESHOWWINDOW; /* Enable wShowWindow control */
+ stStartInfo.wShowWindow = SW_SHOWMINNOACTIVE; /* Start min (normal) */
+
+ if (CreateProcess(
+ cmd, /* Image path */
+ args, /* Arguments for command line */
+ NULL, /* Default process security */
+ NULL, /* Default thread security */
+ FALSE, /* Must be TRUE to use std handles */
+ NORMAL_PRIORITY_CLASS, /* No special scheduling */
+ env, /* Inherit our environment block */
+ dir, /* Inherit our currrent directory */
+ &stStartInfo, /* -> Startup info */
+ &stProcInfo)) /* <- Process info (if OK) */
+ {
+ int pid = (int)stProcInfo.dwProcessId;
+ if (IsWin95() && pid < 0)
+ pid = -pid;
+ sv_setiv(ST(2), pid);
+ CloseHandle(stProcInfo.hThread);/* library source code does this. */
+ bSuccess = TRUE;
+ }
+ PerlEnv_free_childenv(env);
+ PerlEnv_free_childdir(dir);
+ XSRETURN_IV(bSuccess);
+}
+
+XS(w32_GetTickCount)
+{
+ dXSARGS;
+ DWORD msec = GetTickCount();
+ EXTEND(SP,1);
+ if ((IV)msec > 0)
+ XSRETURN_IV(msec);
+ XSRETURN_NV(msec);
+}
+
+XS(w32_GetShortPathName)
+{
+ dXSARGS;
+ SV *shortpath;
+ DWORD len;
+
+ if (items != 1)
+ Perl_croak(aTHX_ "usage: Win32::GetShortPathName($longPathName)");
+
+ if (IsWin2000()) {
+ WCHAR wshort[MAX_PATH+1];
+ WCHAR *wlong = sv_to_wstr(aTHX_ ST(0));
+ len = GetShortPathNameW(wlong, wshort, countof(wshort));
+ Safefree(wlong);
+ if (len && len < sizeof(wshort)) {
+ ST(0) = wstr_to_sv(aTHX_ wshort);
+ XSRETURN(1);
+ }
+ XSRETURN_UNDEF;
+ }
+
+ shortpath = sv_mortalcopy(ST(0));
+ SvUPGRADE(shortpath, SVt_PV);
+ if (!SvPVX(shortpath) || !SvLEN(shortpath))
+ XSRETURN_UNDEF;
+
+ /* src == target is allowed */
+ do {
+ len = GetShortPathName(SvPVX(shortpath),
+ SvPVX(shortpath),
+ (DWORD)SvLEN(shortpath));
+ } while (len >= SvLEN(shortpath) && sv_grow(shortpath,len+1));
+ if (len) {
+ SvCUR_set(shortpath,len);
+ *SvEND(shortpath) = '\0';
+ ST(0) = shortpath;
+ XSRETURN(1);
+ }
+ XSRETURN_UNDEF;
+}
+
+XS(w32_GetFullPathName)
+{
+ dXSARGS;
+ char *fullname;
+ char *ansi = NULL;
+
+/* The code below relies on the fact that PerlDir_mapX() returns an
+ * absolute path, which is only true under PERL_IMPLICIT_SYS when
+ * we use the virtualization code from win32/vdir.h.
+ * Without it PerlDir_mapX() is a no-op and we need to use the same
+ * code as we use for Cygwin.
+ */
+#if __CYGWIN__ || !defined(PERL_IMPLICIT_SYS)
+ char buffer[2*MAX_PATH];
+#endif
+
+ if (items != 1)
+ Perl_croak(aTHX_ "usage: Win32::GetFullPathName($filename)");
+
+#if __CYGWIN__ || !defined(PERL_IMPLICIT_SYS)
+ if (IsWin2000()) {
+ WCHAR *filename = sv_to_wstr(aTHX_ ST(0));
+ WCHAR full[2*MAX_PATH];
+ DWORD len = GetFullPathNameW(filename, countof(full), full, NULL);
+ Safefree(filename);
+ if (len == 0 || len >= countof(full))
+ XSRETURN_EMPTY;
+ ansi = fullname = my_ansipath(full);
+ }
+ else {
+ DWORD len = GetFullPathNameA(SvPV_nolen(ST(0)), countof(buffer), buffer, NULL);
+ if (len == 0 || len >= countof(buffer))
+ XSRETURN_EMPTY;
+ fullname = buffer;
+ }
+#else
+ /* Don't use my_ansipath() unless the $filename argument is in Unicode.
+ * If the relative path doesn't exist, GetShortPathName() will fail and
+ * my_ansipath() will use the long name with replacement characters.
+ * In that case we will be better off using PerlDir_mapA(), which
+ * already uses the ANSI name of the current directory.
+ *
+ * XXX The one missing case is where we could downgrade $filename
+ * XXX from UTF8 into the current codepage.
+ */
+ if (IsWin2000() && SvUTF8(ST(0))) {
+ WCHAR *filename = sv_to_wstr(aTHX_ ST(0));
+ WCHAR *mappedname = PerlDir_mapW(filename);
+ Safefree(filename);
+ ansi = fullname = my_ansipath(mappedname);
+ }
+ else {
+ fullname = PerlDir_mapA(SvPV_nolen(ST(0)));
+ }
+# if PERL_VERSION < 8
+ {
+ /* PerlDir_mapX() in Perl 5.6 used to return forward slashes */
+ char *str = fullname;
+ while (*str) {
+ if (*str == '/')
+ *str = '\\';
+ ++str;
+ }
+ }
+# endif
+#endif
+
+ /* GetFullPathName() on Windows NT drops trailing backslash */
+ if (g_osver.dwMajorVersion == 4 && *fullname) {
+ STRLEN len;
+ char *pv = SvPV(ST(0), len);
+ char *lastchar = fullname + strlen(fullname) - 1;
+ /* If ST(0) ends with a slash, but fullname doesn't ... */
+ if (len && (pv[len-1] == '/' || pv[len-1] == '\\') && *lastchar != '\\') {
+ /* fullname is the MAX_PATH+1 sized buffer returned from PerlDir_mapA()
+ * or the 2*MAX_PATH sized local buffer in the __CYGWIN__ case.
+ */
+ if (lastchar - fullname < MAX_PATH - 1)
+ strcpy(lastchar+1, "\\");
+ }
+ }
+
+ if (GIMME_V == G_ARRAY) {
+ char *filepart = strrchr(fullname, '\\');
+
+ EXTEND(SP,1);
+ if (filepart) {
+ XST_mPV(1, ++filepart);
+ *filepart = '\0';
+ }
+ else {
+ XST_mPVN(1, "", 0);
+ }
+ items = 2;
+ }
+ XST_mPV(0, fullname);
+
+ if (ansi)
+ Safefree(ansi);
+ XSRETURN(items);
+}
+
+XS(w32_GetLongPathName)
+{
+ dXSARGS;
+
+ if (items != 1)
+ Perl_croak(aTHX_ "usage: Win32::GetLongPathName($pathname)");
+
+ if (IsWin2000()) {
+ WCHAR *wstr = sv_to_wstr(aTHX_ ST(0));
+ WCHAR wide_path[MAX_PATH+1];
+ WCHAR *long_path;
+
+ if (wcslen(wstr) < countof(wide_path)) {
+ wcscpy(wide_path, wstr);
+ long_path = my_longpathW(wide_path);
+ if (long_path) {
+ Safefree(wstr);
+ ST(0) = wstr_to_sv(aTHX_ long_path);
+ XSRETURN(1);
+ }
+ }
+ Safefree(wstr);
+ }
+ else {
+ SV *path;
+ char tmpbuf[MAX_PATH+1];
+ char *pathstr;
+ STRLEN len;
+
+ path = ST(0);
+ pathstr = SvPV(path,len);
+ if (len < sizeof(tmpbuf)) {
+ strcpy(tmpbuf, pathstr);
+ pathstr = my_longpathA(tmpbuf);
+ if (pathstr) {
+ ST(0) = sv_2mortal(newSVpvn(pathstr, strlen(pathstr)));
+ XSRETURN(1);
+ }
+ }
+ }
+ XSRETURN_EMPTY;
+}
+
+XS(w32_GetANSIPathName)
+{
+ dXSARGS;
+ WCHAR *wide_path;
+
+ if (items != 1)
+ Perl_croak(aTHX_ "usage: Win32::GetANSIPathName($pathname)");
+
+ wide_path = sv_to_wstr(aTHX_ ST(0));
+ ST(0) = wstr_to_ansipath(aTHX_ wide_path);
+ Safefree(wide_path);
+ XSRETURN(1);
+}
+
+XS(w32_Sleep)
+{
+ dXSARGS;
+ if (items != 1)
+ Perl_croak(aTHX_ "usage: Win32::Sleep($milliseconds)");
+ Sleep((DWORD)SvIV(ST(0)));
+ XSRETURN_YES;
+}
+
+XS(w32_CopyFile)
+{
+ dXSARGS;
+ BOOL bResult;
+ char *pszSourceFile;
+ char szSourceFile[MAX_PATH+1];
+
+ if (items != 3)
+ Perl_croak(aTHX_ "usage: Win32::CopyFile($from, $to, $overwrite)");
+
+ pszSourceFile = PerlDir_mapA(SvPV_nolen(ST(0)));
+ if (strlen(pszSourceFile) < sizeof(szSourceFile)) {
+ strcpy(szSourceFile, pszSourceFile);
+ bResult = CopyFileA(szSourceFile, PerlDir_mapA(SvPV_nolen(ST(1))), !SvTRUE(ST(2)));
+ if (bResult)
+ XSRETURN_YES;
+ }
+ XSRETURN_NO;
+}
+
+XS(w32_OutputDebugString)
+{
+ dXSARGS;
+ if (items != 1)
+ Perl_croak(aTHX_ "usage: Win32::OutputDebugString($string)");
+
+ if (SvUTF8(ST(0))) {
+ WCHAR *str = sv_to_wstr(aTHX_ ST(0));
+ OutputDebugStringW(str);
+ Safefree(str);
+ }
+ else
+ OutputDebugStringA(SvPV_nolen(ST(0)));
+
+ XSRETURN_EMPTY;
+}
+
+XS(w32_GetCurrentProcessId)
+{
+ dXSARGS;
+ EXTEND(SP,1);
+ XSRETURN_IV(GetCurrentProcessId());
+}
+
+XS(w32_GetCurrentThreadId)
+{
+ dXSARGS;
+ EXTEND(SP,1);
+ XSRETURN_IV(GetCurrentThreadId());
+}
+
+XS(w32_CreateDirectory)
+{
+ dXSARGS;
+ BOOL result;
+
+ if (items != 1)
+ Perl_croak(aTHX_ "usage: Win32::CreateDirectory($dir)");
+
+ if (IsWin2000() && SvUTF8(ST(0))) {
+ WCHAR *dir = sv_to_wstr(aTHX_ ST(0));
+ result = CreateDirectoryW(dir, NULL);
+ Safefree(dir);
+ }
+ else {
+ result = CreateDirectoryA(SvPV_nolen(ST(0)), NULL);
+ }
+
+ ST(0) = boolSV(result);
+ XSRETURN(1);
+}
+
+XS(w32_CreateFile)
+{
+ dXSARGS;
+ HANDLE handle;
+
+ if (items != 1)
+ Perl_croak(aTHX_ "usage: Win32::CreateFile($file)");
+
+ if (IsWin2000() && SvUTF8(ST(0))) {
+ WCHAR *file = sv_to_wstr(aTHX_ ST(0));
+ handle = CreateFileW(file, GENERIC_WRITE, FILE_SHARE_WRITE,
+ NULL, CREATE_NEW, FILE_ATTRIBUTE_NORMAL, NULL);
+ Safefree(file);
+ }
+ else {
+ handle = CreateFileA(SvPV_nolen(ST(0)), GENERIC_WRITE, FILE_SHARE_WRITE,
+ NULL, CREATE_NEW, FILE_ATTRIBUTE_NORMAL, NULL);
+ }
+
+ if (handle != INVALID_HANDLE_VALUE)
+ CloseHandle(handle);
+
+ ST(0) = boolSV(handle != INVALID_HANDLE_VALUE);
+ XSRETURN(1);
+}
+
+XS(w32_GetSystemMetrics)
+{
+ dXSARGS;
+
+ if (items != 1)
+ Perl_croak(aTHX_ "usage: Win32::GetSystemMetrics($index)");
+
+ XSRETURN_IV(GetSystemMetrics((int)SvIV(ST(0))));
+}
+
+XS(w32_GetProductInfo)
+{
+ dXSARGS;
+ DWORD type;
+ HMODULE module;
+ PFNGetProductInfo pfnGetProductInfo;
+
+ if (items != 4)
+ Perl_croak(aTHX_ "usage: Win32::GetProductInfo($major,$minor,$spmajor,$spminor)");
+
+ module = GetModuleHandle("kernel32.dll");
+ GETPROC(GetProductInfo);
+ if (pfnGetProductInfo &&
+ pfnGetProductInfo((DWORD)SvIV(ST(0)), (DWORD)SvIV(ST(1)),
+ (DWORD)SvIV(ST(2)), (DWORD)SvIV(ST(3)), &type))
+ {
+ XSRETURN_IV(type);
+ }
+
+ /* PRODUCT_UNDEFINED */
+ XSRETURN_IV(0);
+}
+
+XS(w32_GetACP)
+{
+ dXSARGS;
+ EXTEND(SP,1);
+ XSRETURN_IV(GetACP());
+}
+
+XS(w32_GetConsoleCP)
+{
+ dXSARGS;
+ EXTEND(SP,1);
+ XSRETURN_IV(GetConsoleCP());
+}
+
+XS(w32_GetConsoleOutputCP)
+{
+ dXSARGS;
+ EXTEND(SP,1);
+ XSRETURN_IV(GetConsoleOutputCP());
+}
+
+XS(w32_GetOEMCP)
+{
+ dXSARGS;
+ EXTEND(SP,1);
+ XSRETURN_IV(GetOEMCP());
+}
+
+XS(w32_SetConsoleCP)
+{
+ dXSARGS;
+
+ if (items != 1)
+ Perl_croak(aTHX_ "usage: Win32::SetConsoleCP($id)");
+
+ XSRETURN_IV(SetConsoleCP((int)SvIV(ST(0))));
+}
+
+XS(w32_SetConsoleOutputCP)
+{
+ dXSARGS;
+
+ if (items != 1)
+ Perl_croak(aTHX_ "usage: Win32::SetConsoleOutputCP($id)");
+
+ XSRETURN_IV(SetConsoleOutputCP((int)SvIV(ST(0))));
+}
+
+MODULE = Win32 PACKAGE = Win32
+
+PROTOTYPES: DISABLE
+
+BOOT:
+{
+ char *file = __FILE__;
+
+ if (g_osver.dwOSVersionInfoSize == 0) {
+ g_osver.dwOSVersionInfoSize = sizeof(g_osver);
+ if (!GetVersionExA((OSVERSIONINFOA*)&g_osver)) {
+ g_osver_ex = FALSE;
+ g_osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFOA);
+ GetVersionExA((OSVERSIONINFOA*)&g_osver);
+ }
+ }
+
+ newXS("Win32::LookupAccountName", w32_LookupAccountName, file);
+ newXS("Win32::LookupAccountSID", w32_LookupAccountSID, file);
+ newXS("Win32::InitiateSystemShutdown", w32_InitiateSystemShutdown, file);
+ newXS("Win32::AbortSystemShutdown", w32_AbortSystemShutdown, file);
+ newXS("Win32::ExpandEnvironmentStrings", w32_ExpandEnvironmentStrings, file);
+ newXS("Win32::MsgBox", w32_MsgBox, file);
+ newXS("Win32::LoadLibrary", w32_LoadLibrary, file);
+ newXS("Win32::FreeLibrary", w32_FreeLibrary, file);
+ newXS("Win32::GetProcAddress", w32_GetProcAddress, file);
+ newXS("Win32::RegisterServer", w32_RegisterServer, file);
+ newXS("Win32::UnregisterServer", w32_UnregisterServer, file);
+ newXS("Win32::GetArchName", w32_GetArchName, file);
+ newXS("Win32::GetChipName", w32_GetChipName, file);
+ newXS("Win32::GuidGen", w32_GuidGen, file);
+ newXS("Win32::GetFolderPath", w32_GetFolderPath, file);
+ newXS("Win32::IsAdminUser", w32_IsAdminUser, file);
+ newXS("Win32::GetFileVersion", w32_GetFileVersion, file);
+
+ newXS("Win32::GetCwd", w32_GetCwd, file);
+ newXS("Win32::SetCwd", w32_SetCwd, file);
+ newXS("Win32::GetNextAvailDrive", w32_GetNextAvailDrive, file);
+ newXS("Win32::GetLastError", w32_GetLastError, file);
+ newXS("Win32::SetLastError", w32_SetLastError, file);
+ newXS("Win32::LoginName", w32_LoginName, file);
+ newXS("Win32::NodeName", w32_NodeName, file);
+ newXS("Win32::DomainName", w32_DomainName, file);
+ newXS("Win32::FsType", w32_FsType, file);
+ newXS("Win32::GetOSVersion", w32_GetOSVersion, file);
+ newXS("Win32::IsWinNT", w32_IsWinNT, file);
+ newXS("Win32::IsWin95", w32_IsWin95, file);
+ newXS("Win32::FormatMessage", w32_FormatMessage, file);
+ newXS("Win32::Spawn", w32_Spawn, file);
+ newXS("Win32::GetTickCount", w32_GetTickCount, file);
+ newXS("Win32::GetShortPathName", w32_GetShortPathName, file);
+ newXS("Win32::GetFullPathName", w32_GetFullPathName, file);
+ newXS("Win32::GetLongPathName", w32_GetLongPathName, file);
+ newXS("Win32::GetANSIPathName", w32_GetANSIPathName, file);
+ newXS("Win32::CopyFile", w32_CopyFile, file);
+ newXS("Win32::Sleep", w32_Sleep, file);
+ newXS("Win32::OutputDebugString", w32_OutputDebugString, file);
+ newXS("Win32::GetCurrentProcessId", w32_GetCurrentProcessId, file);
+ newXS("Win32::GetCurrentThreadId", w32_GetCurrentThreadId, file);
+ newXS("Win32::CreateDirectory", w32_CreateDirectory, file);
+ newXS("Win32::CreateFile", w32_CreateFile, file);
+ newXS("Win32::GetSystemMetrics", w32_GetSystemMetrics, file);
+ newXS("Win32::GetProductInfo", w32_GetProductInfo, file);
+ newXS("Win32::GetACP", w32_GetACP, file);
+ newXS("Win32::GetConsoleCP", w32_GetConsoleCP, file);
+ newXS("Win32::GetConsoleOutputCP", w32_GetConsoleOutputCP, file);
+ newXS("Win32::GetOEMCP", w32_GetOEMCP, file);
+ newXS("Win32::SetConsoleCP", w32_SetConsoleCP, file);
+ newXS("Win32::SetConsoleOutputCP", w32_SetConsoleOutputCP, file);
+#ifdef __CYGWIN__
+ newXS("Win32::SetChildShowWindow", w32_SetChildShowWindow, file);
+#endif
+ XSRETURN_YES;
+}
https://perl5.git.perl.org / perl5.git / blobdiff