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