# 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;
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);
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;
}
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
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)
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 *
projects / p5sagit/p5-mst-13.2.git / commitdiff