From: Jan Dubois Date: Fri, 8 Dec 2006 19:07:06 +0000 (-0800) Subject: Second patch from: X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=cf8b4e9375cead6bc605a1dbf0cd13dcc370ae0e;p=p5sagit%2Fp5-mst-13.2.git Second patch from: Subject: [PATCH] Move Win32::* functions from win32/win32.c to ext/Win32/Win32.xs Message-ID: p4raw-id: //depot/perl@29510 --- diff --git a/ext/Win32/Win32.xs b/ext/Win32/Win32.xs index b92ae65..681a683 100644 --- a/ext/Win32/Win32.xs +++ b/ext/Win32/Win32.xs @@ -14,6 +14,22 @@ typedef int (__stdcall *PFNDllUnregisterServer)(void); # define CSIDL_FLAG_CREATE 0x8000 #endif +static OSVERSIONINFO g_osver = {0, 0, 0, 0, 0, ""}; + +#define ONE_K_BUFSIZE 1024 + +int +IsWin95(void) +{ + return (g_osver.dwPlatformId == VER_PLATFORM_WIN32_WINDOWS); +} + +int +IsWinNT(void) +{ + return (g_osver.dwPlatformId == VER_PLATFORM_WIN32_NT); +} + XS(w32_ExpandEnvironmentStrings) { dXSARGS; @@ -524,11 +540,509 @@ XS(w32_GetFileVersion) XSRETURN(items); } +/* + * Extras. + */ + +static +XS(w32_SetChildShowWindow) +{ + dXSARGS; + BOOL use_showwindow = w32_use_showwindow; + /* use "unsigned short" because Perl has redefined "WORD" */ + unsigned short showwindow = w32_showwindow; + + if (items > 1) + Perl_croak(aTHX_ "usage: Win32::SetChildShowWindow($showwindow)"); + + if (items == 0 || !SvOK(ST(0))) + w32_use_showwindow = FALSE; + else { + w32_use_showwindow = TRUE; + w32_showwindow = (unsigned short)SvIV(ST(0)); + } + + EXTEND(SP, 1); + if (use_showwindow) + ST(0) = sv_2mortal(newSViv(showwindow)); + else + ST(0) = &PL_sv_undef; + XSRETURN(1); +} + +static +XS(w32_GetCwd) +{ + dXSARGS; + /* Make the host for current directory */ + char* ptr = PerlEnv_get_childdir(); + /* + * If ptr != Nullch + * then it worked, set PV valid, + * else return 'undef' + */ + if (ptr) { + SV *sv = sv_newmortal(); + sv_setpv(sv, ptr); + PerlEnv_free_childdir(ptr); + +#ifndef INCOMPLETE_TAINTS + SvTAINTED_on(sv); +#endif + + EXTEND(SP,1); + SvPOK_on(sv); + ST(0) = sv; + XSRETURN(1); + } + XSRETURN_UNDEF; +} + +static +XS(w32_SetCwd) +{ + dXSARGS; + if (items != 1) + Perl_croak(aTHX_ "usage: Win32::SetCurrentDirectory($cwd)"); + if (!PerlDir_chdir(SvPV_nolen(ST(0)))) + XSRETURN_YES; + + XSRETURN_NO; +} + +static +XS(w32_GetNextAvailDrive) +{ + dXSARGS; + char ix = 'C'; + char root[] = "_:\\"; + + EXTEND(SP,1); + while (ix <= 'Z') { + root[0] = ix++; + if (GetDriveType(root) == 1) { + root[2] = '\0'; + XSRETURN_PV(root); + } + } + XSRETURN_UNDEF; +} + +static +XS(w32_GetLastError) +{ + dXSARGS; + EXTEND(SP,1); + XSRETURN_IV(GetLastError()); +} + +static +XS(w32_SetLastError) +{ + dXSARGS; + if (items != 1) + Perl_croak(aTHX_ "usage: Win32::SetLastError($error)"); + SetLastError(SvIV(ST(0))); + XSRETURN_EMPTY; +} + +static +XS(w32_LoginName) +{ + dXSARGS; + char *name = w32_getlogin_buffer; + DWORD size = sizeof(w32_getlogin_buffer); + EXTEND(SP,1); + if (GetUserName(name,&size)) { + /* size includes NULL */ + ST(0) = sv_2mortal(newSVpvn(name,size-1)); + XSRETURN(1); + } + XSRETURN_UNDEF; +} + +static +XS(w32_NodeName) +{ + dXSARGS; + char name[MAX_COMPUTERNAME_LENGTH+1]; + DWORD size = sizeof(name); + EXTEND(SP,1); + if (GetComputerName(name,&size)) { + /* size does NOT include NULL :-( */ + ST(0) = sv_2mortal(newSVpvn(name,size)); + XSRETURN(1); + } + XSRETURN_UNDEF; +} + + +static +XS(w32_DomainName) +{ + dXSARGS; + HINSTANCE hNetApi32 = LoadLibrary("netapi32.dll"); + DWORD (__stdcall *pfnNetApiBufferFree)(LPVOID Buffer); + DWORD (__stdcall *pfnNetWkstaGetInfo)(LPWSTR servername, DWORD level, + void *bufptr); + + if (hNetApi32) { + pfnNetApiBufferFree = (DWORD (__stdcall *)(void *)) + GetProcAddress(hNetApi32, "NetApiBufferFree"); + pfnNetWkstaGetInfo = (DWORD (__stdcall *)(LPWSTR, DWORD, void *)) + GetProcAddress(hNetApi32, "NetWkstaGetInfo"); + } + EXTEND(SP,1); + if (hNetApi32 && pfnNetWkstaGetInfo && pfnNetApiBufferFree) { + /* this way is more reliable, in case user has a local account. */ + char dname[256]; + DWORD dnamelen = sizeof(dname); + struct { + DWORD wki100_platform_id; + LPWSTR wki100_computername; + LPWSTR wki100_langroup; + DWORD wki100_ver_major; + DWORD wki100_ver_minor; + } *pwi; + /* NERR_Success *is* 0*/ + if (0 == pfnNetWkstaGetInfo(NULL, 100, &pwi)) { + if (pwi->wki100_langroup && *(pwi->wki100_langroup)) { + WideCharToMultiByte(CP_ACP, 0, pwi->wki100_langroup, + -1, (LPSTR)dname, dnamelen, NULL, NULL); + } + else { + WideCharToMultiByte(CP_ACP, 0, pwi->wki100_computername, + -1, (LPSTR)dname, dnamelen, NULL, NULL); + } + pfnNetApiBufferFree(pwi); + FreeLibrary(hNetApi32); + XSRETURN_PV(dname); + } + FreeLibrary(hNetApi32); + } + else { + /* Win95 doesn't have NetWksta*(), so do it the old way */ + char name[256]; + DWORD size = sizeof(name); + if (hNetApi32) + FreeLibrary(hNetApi32); + if (GetUserName(name,&size)) { + char sid[ONE_K_BUFSIZE]; + DWORD sidlen = sizeof(sid); + char dname[256]; + DWORD dnamelen = sizeof(dname); + SID_NAME_USE snu; + if (LookupAccountName(NULL, name, (PSID)&sid, &sidlen, + dname, &dnamelen, &snu)) { + XSRETURN_PV(dname); /* all that for this */ + } + } + } + XSRETURN_UNDEF; +} + +static +XS(w32_FsType) +{ + dXSARGS; + char fsname[256]; + DWORD flags, filecomplen; + if (GetVolumeInformation(NULL, NULL, 0, NULL, &filecomplen, + &flags, fsname, sizeof(fsname))) { + if (GIMME_V == G_ARRAY) { + XPUSHs(sv_2mortal(newSVpvn(fsname,strlen(fsname)))); + XPUSHs(sv_2mortal(newSViv(flags))); + XPUSHs(sv_2mortal(newSViv(filecomplen))); + PUTBACK; + return; + } + EXTEND(SP,1); + XSRETURN_PV(fsname); + } + XSRETURN_EMPTY; +} + +static +XS(w32_GetOSVersion) +{ + dXSARGS; + /* Use explicit struct definition because wSuiteMask and + * wProductType are not defined in the VC++ 6.0 headers. + * WORD type has been replaced by unsigned short because + * WORD is already used by Perl itself. + */ + struct { + DWORD dwOSVersionInfoSize; + DWORD dwMajorVersion; + DWORD dwMinorVersion; + DWORD dwBuildNumber; + DWORD dwPlatformId; + CHAR szCSDVersion[128]; + unsigned short wServicePackMajor; + unsigned short wServicePackMinor; + unsigned short wSuiteMask; + BYTE wProductType; + BYTE wReserved; + } osver; + BOOL bEx = TRUE; + + osver.dwOSVersionInfoSize = sizeof(osver); + if (!GetVersionExA((OSVERSIONINFOA*)&osver)) { + bEx = FALSE; + osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFOA); + if (!GetVersionExA((OSVERSIONINFOA*)&osver)) { + XSRETURN_EMPTY; + } + } + if (GIMME_V == G_SCALAR) { + XSRETURN_IV(osver.dwPlatformId); + } + XPUSHs(newSVpvn(osver.szCSDVersion, strlen(osver.szCSDVersion))); + + XPUSHs(newSViv(osver.dwMajorVersion)); + XPUSHs(newSViv(osver.dwMinorVersion)); + XPUSHs(newSViv(osver.dwBuildNumber)); + XPUSHs(newSViv(osver.dwPlatformId)); + if (bEx) { + XPUSHs(newSViv(osver.wServicePackMajor)); + XPUSHs(newSViv(osver.wServicePackMinor)); + XPUSHs(newSViv(osver.wSuiteMask)); + XPUSHs(newSViv(osver.wProductType)); + } + PUTBACK; +} + +static +XS(w32_IsWinNT) +{ + dXSARGS; + EXTEND(SP,1); + XSRETURN_IV(IsWinNT()); +} + +static +XS(w32_IsWin95) +{ + dXSARGS; + EXTEND(SP,1); + XSRETURN_IV(IsWin95()); +} + +static +XS(w32_FormatMessage) +{ + dXSARGS; + DWORD source = 0; + char msgbuf[ONE_K_BUFSIZE]; + + if (items != 1) + Perl_croak(aTHX_ "usage: Win32::FormatMessage($errno)"); + + if (FormatMessageA(FORMAT_MESSAGE_FROM_SYSTEM, + &source, SvIV(ST(0)), 0, + msgbuf, sizeof(msgbuf)-1, NULL)) + { + XSRETURN_PV(msgbuf); + } + + XSRETURN_UNDEF; +} + +static +XS(w32_Spawn) +{ + dXSARGS; + char *cmd, *args; + void *env; + char *dir; + PROCESS_INFORMATION stProcInfo; + STARTUPINFO stStartInfo; + BOOL bSuccess = FALSE; + + if (items != 3) + Perl_croak(aTHX_ "usage: Win32::Spawn($cmdName, $args, $PID)"); + + cmd = SvPV_nolen(ST(0)); + args = SvPV_nolen(ST(1)); + + env = PerlEnv_get_childenv(); + dir = PerlEnv_get_childdir(); + + memset(&stStartInfo, 0, sizeof(stStartInfo)); /* Clear the block */ + stStartInfo.cb = sizeof(stStartInfo); /* Set the structure size */ + stStartInfo.dwFlags = STARTF_USESHOWWINDOW; /* Enable wShowWindow control */ + stStartInfo.wShowWindow = SW_SHOWMINNOACTIVE; /* Start min (normal) */ + + if (CreateProcess( + cmd, /* Image path */ + args, /* Arguments for command line */ + NULL, /* Default process security */ + NULL, /* Default thread security */ + FALSE, /* Must be TRUE to use std handles */ + NORMAL_PRIORITY_CLASS, /* No special scheduling */ + env, /* Inherit our environment block */ + dir, /* Inherit our currrent directory */ + &stStartInfo, /* -> Startup info */ + &stProcInfo)) /* <- Process info (if OK) */ + { + int pid = (int)stProcInfo.dwProcessId; + if (IsWin95() && pid < 0) + pid = -pid; + sv_setiv(ST(2), pid); + CloseHandle(stProcInfo.hThread);/* library source code does this. */ + bSuccess = TRUE; + } + PerlEnv_free_childenv(env); + PerlEnv_free_childdir(dir); + XSRETURN_IV(bSuccess); +} + +static +XS(w32_GetTickCount) +{ + dXSARGS; + DWORD msec = GetTickCount(); + EXTEND(SP,1); + if ((IV)msec > 0) + XSRETURN_IV(msec); + XSRETURN_NV(msec); +} + +static +XS(w32_GetShortPathName) +{ + dXSARGS; + SV *shortpath; + DWORD len; + + if (items != 1) + Perl_croak(aTHX_ "usage: Win32::GetShortPathName($longPathName)"); + + shortpath = sv_mortalcopy(ST(0)); + SvUPGRADE(shortpath, SVt_PV); + if (!SvPVX(shortpath) || !SvLEN(shortpath)) + XSRETURN_UNDEF; + + /* src == target is allowed */ + do { + len = GetShortPathName(SvPVX(shortpath), + SvPVX(shortpath), + SvLEN(shortpath)); + } while (len >= SvLEN(shortpath) && sv_grow(shortpath,len+1)); + if (len) { + SvCUR_set(shortpath,len); + *SvEND(shortpath) = '\0'; + ST(0) = shortpath; + XSRETURN(1); + } + XSRETURN_UNDEF; +} + +static +XS(w32_GetFullPathName) +{ + dXSARGS; + SV *filename; + SV *fullpath; + char *filepart; + DWORD len; + STRLEN filename_len; + char *filename_p; + + if (items != 1) + Perl_croak(aTHX_ "usage: Win32::GetFullPathName($filename)"); + + filename = ST(0); + filename_p = SvPV(filename, filename_len); + fullpath = sv_2mortal(newSVpvn(filename_p, filename_len)); + if (!SvPVX(fullpath) || !SvLEN(fullpath)) + XSRETURN_UNDEF; + + do { + len = GetFullPathName(SvPVX(filename), + SvLEN(fullpath), + SvPVX(fullpath), + &filepart); + } while (len >= SvLEN(fullpath) && sv_grow(fullpath,len+1)); + if (len) { + if (GIMME_V == G_ARRAY) { + EXTEND(SP,1); + if (filepart) { + XST_mPV(1,filepart); + len = filepart - SvPVX(fullpath); + } + else { + XST_mPVN(1,"",0); + } + items = 2; + } + SvCUR_set(fullpath,len); + *SvEND(fullpath) = '\0'; + ST(0) = fullpath; + XSRETURN(items); + } + XSRETURN_EMPTY; +} + +static +XS(w32_GetLongPathName) +{ + dXSARGS; + SV *path; + char tmpbuf[MAX_PATH+1]; + char *pathstr; + STRLEN len; + + if (items != 1) + Perl_croak(aTHX_ "usage: Win32::GetLongPathName($pathname)"); + + path = ST(0); + pathstr = SvPV(path,len); + strcpy(tmpbuf, pathstr); + pathstr = win32_longpath(tmpbuf); + if (pathstr) { + ST(0) = sv_2mortal(newSVpvn(pathstr, strlen(pathstr))); + XSRETURN(1); + } + XSRETURN_EMPTY; +} + +static +XS(w32_Sleep) +{ + dXSARGS; + if (items != 1) + Perl_croak(aTHX_ "usage: Win32::Sleep($milliseconds)"); + Sleep(SvIV(ST(0))); + XSRETURN_YES; +} + +static +XS(w32_CopyFile) +{ + dXSARGS; + BOOL bResult; + char szSourceFile[MAX_PATH+1]; + + if (items != 3) + Perl_croak(aTHX_ "usage: Win32::CopyFile($from, $to, $overwrite)"); + strcpy(szSourceFile, PerlDir_mapA(SvPV_nolen(ST(0)))); + bResult = CopyFileA(szSourceFile, PerlDir_mapA(SvPV_nolen(ST(1))), !SvTRUE(ST(2))); + if (bResult) + XSRETURN_YES; + XSRETURN_NO; +} + XS(boot_Win32) { dXSARGS; char *file = __FILE__; + if (g_osver.dwOSVersionInfoSize == 0) { + g_osver.dwOSVersionInfoSize = sizeof(g_osver); + GetVersionEx(&g_osver); + } + newXS("Win32::LookupAccountName", w32_LookupAccountName, file); newXS("Win32::LookupAccountSID", w32_LookupAccountSID, file); newXS("Win32::InitiateSystemShutdown", w32_InitiateSystemShutdown, file); @@ -547,5 +1061,27 @@ XS(boot_Win32) newXS("Win32::IsAdminUser", w32_IsAdminUser, file); newXS("Win32::GetFileVersion", w32_GetFileVersion, file); + newXS("Win32::GetCwd", w32_GetCwd, file); + newXS("Win32::SetCwd", w32_SetCwd, file); + newXS("Win32::GetNextAvailDrive", w32_GetNextAvailDrive, file); + newXS("Win32::GetLastError", w32_GetLastError, file); + newXS("Win32::SetLastError", w32_SetLastError, file); + newXS("Win32::LoginName", w32_LoginName, file); + newXS("Win32::NodeName", w32_NodeName, file); + newXS("Win32::DomainName", w32_DomainName, file); + newXS("Win32::FsType", w32_FsType, file); + newXS("Win32::GetOSVersion", w32_GetOSVersion, file); + newXS("Win32::IsWinNT", w32_IsWinNT, file); + newXS("Win32::IsWin95", w32_IsWin95, file); + newXS("Win32::FormatMessage", w32_FormatMessage, file); + newXS("Win32::Spawn", w32_Spawn, file); + newXS("Win32::GetTickCount", w32_GetTickCount, file); + newXS("Win32::GetShortPathName", w32_GetShortPathName, file); + newXS("Win32::GetFullPathName", w32_GetFullPathName, file); + newXS("Win32::GetLongPathName", w32_GetLongPathName, file); + newXS("Win32::CopyFile", w32_CopyFile, file); + newXS("Win32::Sleep", w32_Sleep, file); + newXS("Win32::SetChildShowWindow", w32_SetChildShowWindow, file); + XSRETURN_YES; } diff --git a/win32/win32.c b/win32/win32.c index a7c409f..16bf51e 100644 --- a/win32/win32.c +++ b/win32/win32.c @@ -121,8 +121,6 @@ END_EXTERN_C static OSVERSIONINFO g_osver = {0, 0, 0, 0, 0, ""}; -#define ONE_K_BUFSIZE 1024 - #ifdef __BORLANDC__ /* Silence STDERR grumblings from Borland's math library. */ DllExport int @@ -4270,498 +4268,38 @@ win32_dynaload(const char* filename) return LoadLibraryExA(PerlDir_mapA(filename), NULL, LOAD_WITH_ALTERED_SEARCH_PATH); } -/* - * Extras. - */ - -static -XS(w32_SetChildShowWindow) -{ - dXSARGS; - BOOL use_showwindow = w32_use_showwindow; - /* use "unsigned short" because Perl has redefined "WORD" */ - unsigned short showwindow = w32_showwindow; - - if (items > 1) - Perl_croak(aTHX_ "usage: Win32::SetChildShowWindow($showwindow)"); - - if (items == 0 || !SvOK(ST(0))) - w32_use_showwindow = FALSE; - else { - w32_use_showwindow = TRUE; - w32_showwindow = (unsigned short)SvIV(ST(0)); - } - - EXTEND(SP, 1); - if (use_showwindow) - ST(0) = sv_2mortal(newSViv(showwindow)); - else - ST(0) = &PL_sv_undef; - XSRETURN(1); -} - -static -XS(w32_GetCwd) -{ - dXSARGS; - /* Make the host for current directory */ - char* ptr = PerlEnv_get_childdir(); - /* - * If ptr != Nullch - * then it worked, set PV valid, - * else return 'undef' - */ - if (ptr) { - SV *sv = sv_newmortal(); - sv_setpv(sv, ptr); - PerlEnv_free_childdir(ptr); - -#ifndef INCOMPLETE_TAINTS - SvTAINTED_on(sv); -#endif - - EXTEND(SP,1); - SvPOK_on(sv); - ST(0) = sv; - XSRETURN(1); - } - XSRETURN_UNDEF; -} - -static -XS(w32_SetCwd) -{ - dXSARGS; - if (items != 1) - Perl_croak(aTHX_ "usage: Win32::SetCurrentDirectory($cwd)"); - if (!PerlDir_chdir(SvPV_nolen(ST(0)))) - XSRETURN_YES; - - XSRETURN_NO; -} - -static -XS(w32_GetNextAvailDrive) -{ - dXSARGS; - char ix = 'C'; - char root[] = "_:\\"; - - EXTEND(SP,1); - while (ix <= 'Z') { - root[0] = ix++; - if (GetDriveType(root) == 1) { - root[2] = '\0'; - XSRETURN_PV(root); - } - } - XSRETURN_UNDEF; -} - -static -XS(w32_GetLastError) -{ - dXSARGS; - EXTEND(SP,1); - XSRETURN_IV(GetLastError()); -} - -static -XS(w32_SetLastError) -{ - dXSARGS; - if (items != 1) - Perl_croak(aTHX_ "usage: Win32::SetLastError($error)"); - SetLastError(SvIV(ST(0))); - XSRETURN_EMPTY; -} - -static -XS(w32_LoginName) -{ - dXSARGS; - char *name = w32_getlogin_buffer; - DWORD size = sizeof(w32_getlogin_buffer); - EXTEND(SP,1); - if (GetUserName(name,&size)) { - /* size includes NULL */ - ST(0) = sv_2mortal(newSVpvn(name,size-1)); - XSRETURN(1); - } - XSRETURN_UNDEF; -} - -static -XS(w32_NodeName) -{ - dXSARGS; - char name[MAX_COMPUTERNAME_LENGTH+1]; - DWORD size = sizeof(name); - EXTEND(SP,1); - if (GetComputerName(name,&size)) { - /* size does NOT include NULL :-( */ - ST(0) = sv_2mortal(newSVpvn(name,size)); - XSRETURN(1); - } - XSRETURN_UNDEF; -} - - -static -XS(w32_DomainName) -{ - dXSARGS; - HINSTANCE hNetApi32 = LoadLibrary("netapi32.dll"); - DWORD (__stdcall *pfnNetApiBufferFree)(LPVOID Buffer); - DWORD (__stdcall *pfnNetWkstaGetInfo)(LPWSTR servername, DWORD level, - void *bufptr); - - if (hNetApi32) { - pfnNetApiBufferFree = (DWORD (__stdcall *)(void *)) - GetProcAddress(hNetApi32, "NetApiBufferFree"); - pfnNetWkstaGetInfo = (DWORD (__stdcall *)(LPWSTR, DWORD, void *)) - GetProcAddress(hNetApi32, "NetWkstaGetInfo"); - } - EXTEND(SP,1); - if (hNetApi32 && pfnNetWkstaGetInfo && pfnNetApiBufferFree) { - /* this way is more reliable, in case user has a local account. */ - char dname[256]; - DWORD dnamelen = sizeof(dname); - struct { - DWORD wki100_platform_id; - LPWSTR wki100_computername; - LPWSTR wki100_langroup; - DWORD wki100_ver_major; - DWORD wki100_ver_minor; - } *pwi; - /* NERR_Success *is* 0*/ - if (0 == pfnNetWkstaGetInfo(NULL, 100, &pwi)) { - if (pwi->wki100_langroup && *(pwi->wki100_langroup)) { - WideCharToMultiByte(CP_ACP, 0, pwi->wki100_langroup, - -1, (LPSTR)dname, dnamelen, NULL, NULL); - } - else { - WideCharToMultiByte(CP_ACP, 0, pwi->wki100_computername, - -1, (LPSTR)dname, dnamelen, NULL, NULL); - } - pfnNetApiBufferFree(pwi); - FreeLibrary(hNetApi32); - XSRETURN_PV(dname); - } - FreeLibrary(hNetApi32); - } - else { - /* Win95 doesn't have NetWksta*(), so do it the old way */ - char name[256]; - DWORD size = sizeof(name); - if (hNetApi32) - FreeLibrary(hNetApi32); - if (GetUserName(name,&size)) { - char sid[ONE_K_BUFSIZE]; - DWORD sidlen = sizeof(sid); - char dname[256]; - DWORD dnamelen = sizeof(dname); - SID_NAME_USE snu; - if (LookupAccountName(NULL, name, (PSID)&sid, &sidlen, - dname, &dnamelen, &snu)) { - XSRETURN_PV(dname); /* all that for this */ - } - } - } - XSRETURN_UNDEF; -} - -static -XS(w32_FsType) -{ - dXSARGS; - char fsname[256]; - DWORD flags, filecomplen; - if (GetVolumeInformation(NULL, NULL, 0, NULL, &filecomplen, - &flags, fsname, sizeof(fsname))) { - if (GIMME_V == G_ARRAY) { - XPUSHs(sv_2mortal(newSVpvn(fsname,strlen(fsname)))); - XPUSHs(sv_2mortal(newSViv(flags))); - XPUSHs(sv_2mortal(newSViv(filecomplen))); - PUTBACK; - return; - } - EXTEND(SP,1); - XSRETURN_PV(fsname); - } - XSRETURN_EMPTY; -} - -static -XS(w32_GetOSVersion) -{ - dXSARGS; - /* Use explicit struct definition because wSuiteMask and - * wProductType are not defined in the VC++ 6.0 headers. - * WORD type has been replaced by unsigned short because - * WORD is already used by Perl itself. - */ - struct { - DWORD dwOSVersionInfoSize; - DWORD dwMajorVersion; - DWORD dwMinorVersion; - DWORD dwBuildNumber; - DWORD dwPlatformId; - CHAR szCSDVersion[128]; - unsigned short wServicePackMajor; - unsigned short wServicePackMinor; - unsigned short wSuiteMask; - BYTE wProductType; - BYTE wReserved; - } osver; - BOOL bEx = TRUE; - - osver.dwOSVersionInfoSize = sizeof(osver); - if (!GetVersionExA((OSVERSIONINFOA*)&osver)) { - bEx = FALSE; - osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFOA); - if (!GetVersionExA((OSVERSIONINFOA*)&osver)) { - XSRETURN_EMPTY; - } - } - if (GIMME_V == G_SCALAR) { - XSRETURN_IV(osver.dwPlatformId); - } - XPUSHs(newSVpvn(osver.szCSDVersion, strlen(osver.szCSDVersion))); - - XPUSHs(newSViv(osver.dwMajorVersion)); - XPUSHs(newSViv(osver.dwMinorVersion)); - XPUSHs(newSViv(osver.dwBuildNumber)); - XPUSHs(newSViv(osver.dwPlatformId)); - if (bEx) { - XPUSHs(newSViv(osver.wServicePackMajor)); - XPUSHs(newSViv(osver.wServicePackMinor)); - XPUSHs(newSViv(osver.wSuiteMask)); - XPUSHs(newSViv(osver.wProductType)); - } - PUTBACK; -} - -static -XS(w32_IsWinNT) -{ - dXSARGS; - EXTEND(SP,1); - XSRETURN_IV(IsWinNT()); -} - -static -XS(w32_IsWin95) -{ - dXSARGS; - EXTEND(SP,1); - XSRETURN_IV(IsWin95()); -} - -static -XS(w32_FormatMessage) -{ - dXSARGS; - DWORD source = 0; - char msgbuf[ONE_K_BUFSIZE]; - - if (items != 1) - Perl_croak(aTHX_ "usage: Win32::FormatMessage($errno)"); - - if (FormatMessageA(FORMAT_MESSAGE_FROM_SYSTEM, - &source, SvIV(ST(0)), 0, - msgbuf, sizeof(msgbuf)-1, NULL)) - { - XSRETURN_PV(msgbuf); - } - - XSRETURN_UNDEF; -} - -static -XS(w32_Spawn) -{ - dXSARGS; - char *cmd, *args; - void *env; - char *dir; - PROCESS_INFORMATION stProcInfo; - STARTUPINFO stStartInfo; - BOOL bSuccess = FALSE; - - if (items != 3) - Perl_croak(aTHX_ "usage: Win32::Spawn($cmdName, $args, $PID)"); - - cmd = SvPV_nolen(ST(0)); - args = SvPV_nolen(ST(1)); - - env = PerlEnv_get_childenv(); - dir = PerlEnv_get_childdir(); - - memset(&stStartInfo, 0, sizeof(stStartInfo)); /* Clear the block */ - stStartInfo.cb = sizeof(stStartInfo); /* Set the structure size */ - stStartInfo.dwFlags = STARTF_USESHOWWINDOW; /* Enable wShowWindow control */ - stStartInfo.wShowWindow = SW_SHOWMINNOACTIVE; /* Start min (normal) */ - - if (CreateProcess( - cmd, /* Image path */ - args, /* Arguments for command line */ - NULL, /* Default process security */ - NULL, /* Default thread security */ - FALSE, /* Must be TRUE to use std handles */ - NORMAL_PRIORITY_CLASS, /* No special scheduling */ - env, /* Inherit our environment block */ - dir, /* Inherit our currrent directory */ - &stStartInfo, /* -> Startup info */ - &stProcInfo)) /* <- Process info (if OK) */ - { - int pid = (int)stProcInfo.dwProcessId; - if (IsWin95() && pid < 0) - pid = -pid; - sv_setiv(ST(2), pid); - CloseHandle(stProcInfo.hThread);/* library source code does this. */ - bSuccess = TRUE; - } - PerlEnv_free_childenv(env); - PerlEnv_free_childdir(dir); - XSRETURN_IV(bSuccess); -} - -static -XS(w32_GetTickCount) -{ - dXSARGS; - DWORD msec = GetTickCount(); - EXTEND(SP,1); - if ((IV)msec > 0) - XSRETURN_IV(msec); - XSRETURN_NV(msec); -} - -static -XS(w32_GetShortPathName) -{ - dXSARGS; - SV *shortpath; - DWORD len; - - if (items != 1) - Perl_croak(aTHX_ "usage: Win32::GetShortPathName($longPathName)"); - - shortpath = sv_mortalcopy(ST(0)); - SvUPGRADE(shortpath, SVt_PV); - if (!SvPVX(shortpath) || !SvLEN(shortpath)) - XSRETURN_UNDEF; - - /* src == target is allowed */ - do { - len = GetShortPathName(SvPVX(shortpath), - SvPVX(shortpath), - SvLEN(shortpath)); - } while (len >= SvLEN(shortpath) && sv_grow(shortpath,len+1)); - if (len) { - SvCUR_set(shortpath,len); - *SvEND(shortpath) = '\0'; - ST(0) = shortpath; - XSRETURN(1); - } - XSRETURN_UNDEF; -} - -static -XS(w32_GetFullPathName) -{ - dXSARGS; - SV *filename; - SV *fullpath; - char *filepart; - DWORD len; - STRLEN filename_len; - char *filename_p; - - if (items != 1) - Perl_croak(aTHX_ "usage: Win32::GetFullPathName($filename)"); - - filename = ST(0); - filename_p = SvPV(filename, filename_len); - fullpath = sv_2mortal(newSVpvn(filename_p, filename_len)); - if (!SvPVX(fullpath) || !SvLEN(fullpath)) - XSRETURN_UNDEF; - - do { - len = GetFullPathName(SvPVX(filename), - SvLEN(fullpath), - SvPVX(fullpath), - &filepart); - } while (len >= SvLEN(fullpath) && sv_grow(fullpath,len+1)); - if (len) { - if (GIMME_V == G_ARRAY) { - EXTEND(SP,1); - if (filepart) { - XST_mPV(1,filepart); - len = filepart - SvPVX(fullpath); - } - else { - XST_mPVN(1,"",0); - } - items = 2; - } - SvCUR_set(fullpath,len); - *SvEND(fullpath) = '\0'; - ST(0) = fullpath; - XSRETURN(items); - } - XSRETURN_EMPTY; -} - -static -XS(w32_GetLongPathName) -{ - dXSARGS; - SV *path; - char tmpbuf[MAX_PATH+1]; - char *pathstr; - STRLEN len; - - if (items != 1) - Perl_croak(aTHX_ "usage: Win32::GetLongPathName($pathname)"); - - path = ST(0); - pathstr = SvPV(path,len); - strcpy(tmpbuf, pathstr); - pathstr = win32_longpath(tmpbuf); - if (pathstr) { - ST(0) = sv_2mortal(newSVpvn(pathstr, strlen(pathstr))); - XSRETURN(1); - } - XSRETURN_EMPTY; -} - -static -XS(w32_Sleep) -{ - dXSARGS; - if (items != 1) - Perl_croak(aTHX_ "usage: Win32::Sleep($milliseconds)"); - Sleep(SvIV(ST(0))); - XSRETURN_YES; -} - -static -XS(w32_CopyFile) +static void +forward(pTHX_ const char *function) { dXSARGS; - BOOL bResult; - char szSourceFile[MAX_PATH+1]; - - if (items != 3) - Perl_croak(aTHX_ "usage: Win32::CopyFile($from, $to, $overwrite)"); - strcpy(szSourceFile, PerlDir_mapA(SvPV_nolen(ST(0)))); - bResult = CopyFileA(szSourceFile, PerlDir_mapA(SvPV_nolen(ST(1))), !SvTRUE(ST(2))); - if (bResult) - XSRETURN_YES; - XSRETURN_NO; -} + Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvn("Win32",5), NULL); + PUSHMARK(SP-items); + call_pv(function, GIMME_V); +} + +#define FORWARD(function) XS(w32_##function){ forward(aTHX_ "Win32::"#function); } +FORWARD(GetCwd) +FORWARD(SetCwd) +FORWARD(GetNextAvailDrive) +FORWARD(GetLastError) +FORWARD(SetLastError) +FORWARD(LoginName) +FORWARD(NodeName) +FORWARD(DomainName) +FORWARD(FsType) +FORWARD(GetOSVersion) +FORWARD(IsWinNT) +FORWARD(IsWin95) +FORWARD(FormatMessage) +FORWARD(Spawn) +FORWARD(GetTickCount) +FORWARD(GetShortPathName) +FORWARD(GetFullPathName) +FORWARD(GetLongPathName) +FORWARD(CopyFile) +FORWARD(Sleep) +FORWARD(SetChildShowWindow) +#undef FORWARD void Perl_init_os_extras(void) @@ -4792,17 +4330,6 @@ Perl_init_os_extras(void) newXS("Win32::CopyFile", w32_CopyFile, file); newXS("Win32::Sleep", w32_Sleep, file); newXS("Win32::SetChildShowWindow", w32_SetChildShowWindow, file); - - /* XXX Bloat Alert! The following Activeware preloads really - * ought to be part of Win32::Sys::*, so they're not included - * here. - */ - /* LookupAccountName - * LookupAccountSID - * InitiateSystemShutdown - * AbortSystemShutdown - * ExpandEnvrironmentStrings - */ } void *