ext/Win32/Win32.xs

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