diff options
author | Douglas Lankshear <doug@lankshear.net> | 1998-02-12 22:14:51 -0800 |
---|---|---|
committer | Gurusamy Sarathy <gsar@cpan.org> | 1998-02-14 00:42:37 +0000 |
commit | 9d8a25dc64d23dcd5730db9be0dbe94a107e1f8b (patch) | |
tree | 6b1cd171d4482f416a67530f23e2bb55e51341b9 /win32 | |
parent | 7fae4e64c5e2903183a8656ece6686238ddef215 (diff) | |
download | perl-9d8a25dc64d23dcd5730db9be0dbe94a107e1f8b.tar.gz |
[asperl] added AS patch#6
Message-Id: <01BD3846.B29FB880.dougl@ActiveState.com>
Subject: [PATCH] command line build
This patch is for the command line build of perl object.
I'll merge the ipfoo.c function with win32_xxx functions next.
-- Doug
p4raw-id: //depot/asperl@522
Diffstat (limited to 'win32')
-rw-r--r-- | win32/dl_win32.xs | 8 | ||||
-rw-r--r-- | win32/ipenv.c | 64 | ||||
-rw-r--r-- | win32/ipstdio.c | 283 | ||||
-rw-r--r-- | win32/makedef.pl | 44 | ||||
-rw-r--r-- | win32/runperl.c | 4 | ||||
-rw-r--r-- | win32/win32.h | 10 |
6 files changed, 404 insertions, 9 deletions
diff --git a/win32/dl_win32.xs b/win32/dl_win32.xs index f25a30f6ad..077fb22715 100644 --- a/win32/dl_win32.xs +++ b/win32/dl_win32.xs @@ -58,7 +58,7 @@ dl_static_linked(char *filename) MODULE = DynaLoader PACKAGE = DynaLoader BOOT: - (void)dl_private_init(); + (void)dl_private_init(THIS); void * dl_load_file(filename,flags=0) @@ -74,7 +74,7 @@ dl_load_file(filename,flags=0) DLDEBUG(2,PerlIO_printf(PerlIO_stderr()," libref=%x\n", RETVAL)); ST(0) = sv_newmortal() ; if (RETVAL == NULL) - SaveError("%d",GetLastError()) ; + SaveError(THIS_ "%d",GetLastError()) ; else sv_setiv( ST(0), (IV)RETVAL); @@ -90,7 +90,7 @@ dl_find_symbol(libhandle, symbolname) DLDEBUG(2,PerlIO_printf(PerlIO_stderr()," symbolref = %x\n", RETVAL)); ST(0) = sv_newmortal() ; if (RETVAL == NULL) - SaveError("%d",GetLastError()) ; + SaveError(THIS_ "%d",GetLastError()) ; else sv_setiv( ST(0), (IV)RETVAL); @@ -111,7 +111,7 @@ dl_install_xsub(perl_name, symref, filename="$Package") CODE: DLDEBUG(2,PerlIO_printf(PerlIO_stderr(),"dl_install_xsub(name=%s, symref=%x)\n", perl_name, symref)); - ST(0)=sv_2mortal(newRV((SV*)newXS(perl_name, (void(*)(CV*))symref, filename))); + ST(0)=sv_2mortal(newRV((SV*)newXS(perl_name, (void(*)(CPERLarg_ CV*))symref, filename))); char * diff --git a/win32/ipenv.c b/win32/ipenv.c index 9033b55138..5939c11d20 100644 --- a/win32/ipenv.c +++ b/win32/ipenv.c @@ -18,14 +18,68 @@ public: inline void SetPerlObj(CPerlObj *p) { pPerl = p; }; protected: - char w32_perllib_root[MAX_PATH+1]; - HANDLE w32_perldll_handle; - CPerlObj *pPerl; + char w32_perllib_root[MAX_PATH+1]; + HANDLE w32_perldll_handle; + CPerlObj *pPerl; }; + +BOOL GetRegStr(HKEY hkey, const char *lpszValueName, char *lpszDefault, char *lpszData, unsigned long *lpdwDataLen) +{ // Retrieve a REG_SZ or REG_EXPAND_SZ from the registry + HKEY handle; + DWORD type, dwDataLen = *lpdwDataLen; + const char *subkey = "Software\\Perl"; + char szBuffer[MAX_PATH+1]; + long retval; + + retval = RegOpenKeyEx(hkey, subkey, 0, KEY_READ, &handle); + if(retval == ERROR_SUCCESS) + { + retval = RegQueryValueEx(handle, lpszValueName, 0, &type, (LPBYTE)lpszData, &dwDataLen); + RegCloseKey(handle); + if(retval == ERROR_SUCCESS && (type == REG_SZ || type == REG_EXPAND_SZ)) + { + if(type != REG_EXPAND_SZ) + { + *lpdwDataLen = dwDataLen; + return TRUE; + } + strcpy(szBuffer, lpszData); + dwDataLen = ExpandEnvironmentStrings(szBuffer, lpszData, *lpdwDataLen); + if(dwDataLen < *lpdwDataLen) + { + *lpdwDataLen = dwDataLen; + return TRUE; + } + } + } + + strcpy(lpszData, lpszDefault); + return FALSE; +} + +char* GetRegStr(const char *lpszValueName, char *lpszDefault, char *lpszData, unsigned long *lpdwDataLen) +{ + if(!GetRegStr(HKEY_CURRENT_USER, lpszValueName, lpszDefault, lpszData, lpdwDataLen)) + { + GetRegStr(HKEY_LOCAL_MACHINE, lpszValueName, lpszDefault, lpszData, lpdwDataLen); + } + if(*lpszData == '\0') + lpszData = NULL; + return lpszData; +} + + char *CPerlEnv::Getenv(const char *varname, int &err) { - return getenv(varname); + char* ptr = getenv(varname); + if(ptr == NULL) + { + unsigned long dwDataLen = sizeof(w32_perllib_root); + if(strcmp("PERL5DB", varname) == 0) + ptr = GetRegStr(varname, "", w32_perllib_root, &dwDataLen); + } + return ptr; } int CPerlEnv::Putenv(const char *envstring, int &err) @@ -40,7 +94,7 @@ char* CPerlEnv::LibPath(char *sfx, ...) va_start(ap,sfx); GetModuleFileName((w32_perldll_handle == INVALID_HANDLE_VALUE) ? GetModuleHandle(NULL) - : w32_perldll_handle, + : (HINSTANCE)w32_perldll_handle, w32_perllib_root, sizeof(w32_perllib_root)); *(end = strrchr(w32_perllib_root, '\\')) = '\0'; diff --git a/win32/ipstdio.c b/win32/ipstdio.c index d95c6921a4..795b901db8 100644 --- a/win32/ipstdio.c +++ b/win32/ipstdio.c @@ -466,8 +466,291 @@ void CPerlStdIO::Init(int &err) { } + +static +XS(w32_GetCwd) +{ + dXSARGS; + SV *sv = sv_newmortal(); + /* Make one call with zero size - return value is required size */ + DWORD len = GetCurrentDirectory((DWORD)0,NULL); + SvUPGRADE(sv,SVt_PV); + SvGROW(sv,len); + SvCUR(sv) = GetCurrentDirectory((DWORD) SvLEN(sv), SvPVX(sv)); + /* + * If result != 0 + * then it worked, set PV valid, + * else leave it 'undef' + */ + if (SvCUR(sv)) + SvPOK_on(sv); + EXTEND(sp,1); + ST(0) = sv; + XSRETURN(1); +} + +static +XS(w32_SetCwd) +{ + dXSARGS; + if (items != 1) + croak("usage: Win32::SetCurrentDirectory($cwd)"); + if (SetCurrentDirectory(SvPV(ST(0),na))) + XSRETURN_YES; + + XSRETURN_NO; +} + +static +XS(w32_GetNextAvailDrive) +{ + dXSARGS; + char ix = 'C'; + char root[] = "_:\\"; + while (ix <= 'Z') { + root[0] = ix++; + if (GetDriveType(root) == 1) { + root[2] = '\0'; + XSRETURN_PV(root); + } + } + XSRETURN_UNDEF; +} + +static +XS(w32_GetLastError) +{ + dXSARGS; + XSRETURN_IV(GetLastError()); +} + +static +XS(w32_LoginName) +{ + dXSARGS; + char szBuffer[128]; + DWORD size = sizeof(szBuffer); + if (GetUserName(szBuffer, &size)) { + /* size includes NULL */ + ST(0) = sv_2mortal(newSVpv(szBuffer,size-1)); + XSRETURN(1); + } + XSRETURN_UNDEF; +} + +static +XS(w32_NodeName) +{ + dXSARGS; + char name[MAX_COMPUTERNAME_LENGTH+1]; + DWORD size = sizeof(name); + if (GetComputerName(name,&size)) { + /* size does NOT include NULL :-( */ + ST(0) = sv_2mortal(newSVpv(name,size)); + XSRETURN(1); + } + XSRETURN_UNDEF; +} + + +static +XS(w32_DomainName) +{ + dXSARGS; + char name[256]; + DWORD size = sizeof(name); + if (GetUserName(name,&size)) { + char sid[1024]; + DWORD sidlen = sizeof(sid); + char dname[256]; + DWORD dnamelen = sizeof(dname); + SID_NAME_USE snu; + if (LookupAccountName(NULL, name, &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 == G_ARRAY) { + XPUSHs(sv_2mortal(newSVpv(fsname,0))); + XPUSHs(sv_2mortal(newSViv(flags))); + XPUSHs(sv_2mortal(newSViv(filecomplen))); + PUTBACK; + return; + } + XSRETURN_PV(fsname); + } + XSRETURN_UNDEF; +} + +static +XS(w32_GetOSVersion) +{ + dXSARGS; + OSVERSIONINFO osver; + + osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFO); + if (GetVersionEx(&osver)) { + XPUSHs(newSVpv(osver.szCSDVersion, 0)); + XPUSHs(newSViv(osver.dwMajorVersion)); + XPUSHs(newSViv(osver.dwMinorVersion)); + XPUSHs(newSViv(osver.dwBuildNumber)); + XPUSHs(newSViv(osver.dwPlatformId)); + PUTBACK; + return; + } + XSRETURN_UNDEF; +} + +static +XS(w32_IsWinNT) +{ + dXSARGS; + OSVERSIONINFO osver; + memset(&osver, 0, sizeof(OSVERSIONINFO)); + osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFO); + GetVersionEx(&osver); + XSRETURN_IV(VER_PLATFORM_WIN32_NT == osver.dwPlatformId); +} + +static +XS(w32_IsWin95) +{ + dXSARGS; + OSVERSIONINFO osver; + memset(&osver, 0, sizeof(OSVERSIONINFO)); + osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFO); + GetVersionEx(&osver); + XSRETURN_IV(VER_PLATFORM_WIN32_WINDOWS == osver.dwPlatformId); +} + +static +XS(w32_FormatMessage) +{ + dXSARGS; + DWORD source = 0; + char msgbuf[1024]; + + if (items != 1) + croak("usage: Win32::FormatMessage($errno)"); + + if (FormatMessage(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; + PROCESS_INFORMATION stProcInfo; + STARTUPINFO stStartInfo; + BOOL bSuccess = FALSE; + + if(items != 3) + croak("usage: Win32::Spawn($cmdName, $args, $PID)"); + + cmd = SvPV(ST(0),na); + args = SvPV(ST(1), na); + + 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 */ + NULL, /* Inherit our environment block */ + NULL, /* Inherit our currrent directory */ + &stStartInfo, /* -> Startup info */ + &stProcInfo)) /* <- Process info (if OK) */ + { + CloseHandle(stProcInfo.hThread);/* library source code does this. */ + sv_setiv(ST(2), stProcInfo.dwProcessId); + bSuccess = TRUE; + } + XSRETURN_IV(bSuccess); +} + +static +XS(w32_GetTickCount) +{ + dXSARGS; + XSRETURN_IV(GetTickCount()); +} + +static +XS(w32_GetShortPathName) +{ + dXSARGS; + SV *shortpath; + DWORD len; + + if(items != 1) + croak("usage: Win32::GetShortPathName($longPathName)"); + + shortpath = sv_mortalcopy(ST(0)); + SvUPGRADE(shortpath, SVt_PV); + /* 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); + ST(0) = shortpath; + } + else + ST(0) = &sv_undef; + XSRETURN(1); +} + + void CPerlStdIO::InitOSExtras(void* p) { + char *file = __FILE__; + dXSUB_SYS; + + /* XXX should be removed after checking with Nick */ + newXS("Win32::GetCurrentDirectory", w32_GetCwd, file); + + /* these names are Activeware compatible */ + 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::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); + } diff --git a/win32/makedef.pl b/win32/makedef.pl index aa0fe34096..52be7f6609 100644 --- a/win32/makedef.pl +++ b/win32/makedef.pl @@ -70,15 +70,20 @@ sub emit_symbols skip_symbols [qw( Perl_statusvalue_vms +Perl_archpat_auto Perl_block_type +Perl_bostr Perl_additem Perl_cast_ulong Perl_check_uni Perl_checkcomma Perl_chsize Perl_ck_aelem +Perl_colors +Perl_colorset Perl_cryptseen Perl_cx_dump +Perl_DBcv Perl_deb Perl_deb_growlevel Perl_debop @@ -105,15 +110,22 @@ Perl_dump_pm Perl_dump_sub Perl_expectterm Perl_error_no +Perl_extralen Perl_fetch_gv Perl_fetch_io Perl_force_ident Perl_force_next Perl_force_word +Perl_generation Perl_hv_stashpv +Perl_in_clean_all +Perl_in_clean_objs Perl_intuit_more Perl_init_thread_intern Perl_know_next +Perl_lastgotoprobe +Perl_linestart +Perl_modcount Perl_modkids Perl_mstats Perl_my_bzero @@ -126,6 +138,7 @@ Perl_no_fh_allowed Perl_no_op Perl_nointrp Perl_nomem +Perl_pending_ident Perl_pp_cswitch Perl_pp_entersubr Perl_pp_evalonce @@ -135,13 +148,41 @@ Perl_pp_nswitch Perl_q Perl_rcsid Perl_reall_srchlen +Perl_reg_eval_set +Perl_reg_flags +Perl_reg_start_tmp +Perl_reg_start_tmpl +Perl_regbol +Perl_regcc +Perl_regcode +Perl_regdata +Perl_regdummy Perl_regdump Perl_regfold +Perl_regendp +Perl_regeol +Perl_regflags +Perl_regindent +Perl_reginput +Perl_reglastparen Perl_regmyendp Perl_regmyp_size Perl_regmystartp Perl_regnarrate +Perl_regnaughty +Perl_regnpar +Perl_regparse +Perl_regprecomp +Perl_regprev +Perl_regprogram Perl_regprop +Perl_regsawback +Perl_regseen +Perl_regsize +Perl_regstartp +Perl_regtill +Perl_regxend +Perl_rx Perl_same_dirent Perl_saw_return Perl_scan_const @@ -155,10 +196,13 @@ Perl_scan_str Perl_scan_subst Perl_scan_trans Perl_scan_word +Perl_seen_zerolen Perl_setenv_getix Perl_skipspace Perl_sort_mutex +Perl_sortcxix Perl_sublex_done +Perl_sublex_info Perl_sublex_start Perl_sv_ref Perl_sv_setptrobj diff --git a/win32/runperl.c b/win32/runperl.c index 5cacb83ca5..b7f61a243e 100644 --- a/win32/runperl.c +++ b/win32/runperl.c @@ -174,6 +174,10 @@ static void xs_init(CPERLarg) { } +EXTERN_C void boot_DynaLoader _((CPERLarg_ CV* cv)) +{ +} + #else /* PERL_OBJECT */ /* Say NO to CPP! Hallelujah! */ diff --git a/win32/win32.h b/win32/win32.h index 8d6b04197d..31aadf960e 100644 --- a/win32/win32.h +++ b/win32/win32.h @@ -9,6 +9,16 @@ #ifndef _INC_WIN32_PERL5 #define _INC_WIN32_PERL5 +#ifdef PERL_OBJECT +#define ENV_HV_NAME "ENV_HV_NAME" +#define DYNAMIC_ENV_FETCH +#define prime_env_iter() +#ifdef PERL_GLOBAL_STRUCT +#error PERL_GLOBAL_STRUCT cannot be defined with PERL_OBJECT +#endif +#define win32_perllib_path PerlEnv_lib_path +#endif + #ifdef __GNUC__ typedef long long __int64; #define Win32_Winsock |