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