From: Douglas Lankshear Date: Fri, 13 Feb 1998 06:14:51 +0000 (-0800) Subject: [asperl] added AS patch#6 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=9d8a25dc64d23dcd5730db9be0dbe94a107e1f8b;p=p5sagit%2Fp5-mst-13.2.git [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 --- diff --git a/ObjXSub.h b/ObjXSub.h index eadd922..d49f49a 100644 --- a/ObjXSub.h +++ b/ObjXSub.h @@ -20,6 +20,8 @@ #define cop_seqmax pPerl->Perl_cop_seqmax #undef defstash #define defstash pPerl->Perl_defstash +#undef dowarn +#define dowarn pPerl->Perl_dowarn #undef evalseq #define evalseq pPerl->Perl_evalseq #undef hexdigit @@ -64,6 +66,10 @@ #define savestack_ix pPerl->Perl_savestack_ix #undef savestack_max #define savestack_max pPerl->Perl_savestack_max +#undef tmps_floor +#define tmps_floor pPerl->Perl_tmps_floor +#undef tmps_ix +#define tmps_ix pPerl->Perl_tmps_ix #undef retstack #define retstack pPerl->Perl_retstack #undef retstack_ix @@ -119,16 +125,6 @@ #define yyval pPerl->Perl_yyval #undef yylval #define yylval pPerl->Perl_yylval -#undef last_hkey -#define last_hkey pPerl->Perl_last_hkey -#undef valbuf -#define valbuf pPerl->Perl_valbuf -#undef namebuf -#define namebuf pPerl->Perl_namebuf -#undef maxvalsz -#define maxvalsz pPerl->Perl_maxvalsz -#undef maxnamesz -#define maxnamesz pPerl->Perl_maxnamesz // functions @@ -176,6 +172,8 @@ #define bind_match pPerl->Perl_bind_match #undef block_end #define block_end pPerl->Perl_block_end +#undef block_gimme +#define block_gimme pPerl->Perl_block_gimme #undef block_start #define block_start pPerl->Perl_block_start #undef call_list @@ -330,6 +328,8 @@ #define force_next pPerl->Perl_force_next #undef force_word #define force_word pPerl->Perl_force_word +#undef form +#define form pPerl->Perl_form #undef fold_constants #define fold_constants pPerl->Perl_fold_constants #undef fprintf @@ -666,6 +666,9 @@ #define newPVOP pPerl->Perl_newPVOP #undef newRV #define newRV pPerl->Perl_newRV +#undef newRV_noinc +#undef Perl_newRV_noinc +#define newRV_noinc pPerl->Perl_newRV_noinc #undef newSV #define newSV pPerl->Perl_newSV #undef newSV @@ -970,6 +973,8 @@ #define sv_bless pPerl->Perl_sv_bless #undef sv_catpv #define sv_catpv pPerl->Perl_sv_catpv +#undef sv_catpvf +#define sv_catpvf pPerl->Perl_sv_catpvf #undef sv_catpvn #define sv_catpvn pPerl->Perl_sv_catpvn #undef sv_catsv @@ -1046,6 +1051,8 @@ #define sv_setref_pvn pPerl->Perl_sv_setref_pvn #undef sv_setpv #define sv_setpv pPerl->Perl_sv_setpv +#undef sv_setpvf +#define sv_setpvf pPerl->Perl_sv_setpvf #undef sv_setpvn #define sv_setpvn pPerl->Perl_sv_setpvn #undef sv_setsv @@ -1060,6 +1067,8 @@ #define sv_upgrade pPerl->Perl_sv_upgrade #undef sv_usepvn #define sv_usepvn pPerl->Perl_sv_usepvn +#undef sv_vsetpvfn +#define sv_vsetpvfn pPerl->Perl_sv_vsetpvfn #undef taint_env #define taint_env pPerl->Perl_taint_env #undef taint_not @@ -1089,11 +1098,6 @@ #undef piProc #define piProc (pPerl->piProc) -#undef SAVETMPS -#define SAVETMPS pPerl->SaveTmps() -#undef FREETMPS -#define FREETMPS pPerl->FreeTmps() - #ifndef NO_XSLOCKS #undef closedir #undef opendir @@ -1247,17 +1251,14 @@ #undef THIS_ #define THIS_ pPerl, +#undef SAVEDESTRUCTOR +#define SAVEDESTRUCTOR(f,p) pPerl->Perl_save_destructor((f),(p)) + #ifdef WIN32 #undef errno #define errno ErrorNo() #undef ErrorNo #define ErrorNo pPerl->ErrorNo -#undef LastOLEError -#define LastOLEError pPerl->Perl_LastOLEError -#undef bOleInit -#define bOleInit pPerl->Perl_bOleInit -#undef CreatePerlOLEObject -#define CreatePerlOLEObject pPerl->CreatePerlOLEObject #undef NtCrypt #define NtCrypt pPerl->NtCrypt #undef NtGetLib diff --git a/ext/Opcode/Opcode.xs b/ext/Opcode/Opcode.xs index cf5c859..22d424d 100644 --- a/ext/Opcode/Opcode.xs +++ b/ext/Opcode/Opcode.xs @@ -202,7 +202,7 @@ opmask_addlocal(SV *opset, char *op_mask_buf) /* Localise op_mask then opmask_ad char *orig_op_mask = op_mask; SAVEPPTR(op_mask); if (opcode_debug >= 2) - SAVEDESTRUCTOR((void(*)_((void*)))warn,"op_mask restored"); + SAVEDESTRUCTOR((void(CPERLscope(*))_((void*)))warn,"op_mask restored"); op_mask = &op_mask_buf[0]; if (orig_op_mask) Copy(orig_op_mask, op_mask, maxo, char); @@ -226,8 +226,8 @@ BOOT: void -_safe_call_sv(package, mask, codesv) - char * package +_safe_call_sv(Package, mask, codesv) + char * Package SV * mask SV * codesv PPCODE: @@ -243,7 +243,7 @@ _safe_call_sv(package, mask, codesv) save_hptr(&defstash); /* save current default stack */ /* the assignment to global defstash changes our sense of 'main' */ - defstash = gv_stashpv(package, GV_ADDWARN); /* should exist already */ + defstash = gv_stashpv(Package, GV_ADDWARN); /* should exist already */ /* defstash must itself contain a main:: so we'll add that now */ /* take care with the ref counts (was cause of long standing bug) */ diff --git a/lib/ExtUtils/MM_Win32.pm b/lib/ExtUtils/MM_Win32.pm index 101f76a..ae2ef48 100644 --- a/lib/ExtUtils/MM_Win32.pm +++ b/lib/ExtUtils/MM_Win32.pm @@ -33,6 +33,7 @@ $BORLAND = 1 if $Config{'cc'} =~ /^bcc/i; $GCC = 1 if $Config{'cc'} =~ /^gcc/i; $DMAKE = 1 if $Config{'make'} =~ /^dmake/i; $NMAKE = 1 if $Config{'make'} =~ /^nmake/i; +$OBJ = 1 if $Config{'ccflags'} =~ /PERL_OBJECT/i; sub dlsyms { my($self,%attribs) = @_; @@ -163,7 +164,8 @@ sub init_others $self->{'LDLOADLIBS'} ||= ( $BORLAND ? 'import32.lib cw32mti.lib ' - : 'msvcrt.lib oldnames.lib kernel32.lib comdlg32.lib winspool.lib gdi32.lib ' + : ( $OBJ ? '' : 'msvcrt.lib ' ) + .'oldnames.lib kernel32.lib comdlg32.lib winspool.lib gdi32.lib ' .'advapi32.lib user32.lib shell32.lib netapi32.lib ole32.lib ' .'oleaut32.lib uuid.lib wsock32.lib mpr.lib winmm.lib version.lib ' ) . ' odbc32.lib odbccp32.lib'; diff --git a/objpp.h b/objpp.h index f1d8c06..9e701ff 100644 --- a/objpp.h +++ b/objpp.h @@ -648,7 +648,7 @@ #undef mg_get #define mg_get CPerlObj::Perl_mg_get #undef mg_length -#define mg_length CPerlObj::mg_length +#define mg_length CPerlObj::Perl_mg_length #undef mg_magical #define mg_magical CPerlObj::Perl_mg_magical #undef mg_set @@ -697,6 +697,8 @@ #define my_pclose CPerlObj::Perl_my_pclose #undef my_popen #define my_popen CPerlObj::Perl_my_popen +#undef my_safemalloc +#define my_safemalloc CPerlObj::my_safemalloc #undef my_setenv #define my_setenv CPerlObj::Perl_my_setenv #undef my_stat @@ -803,6 +805,8 @@ #define newSVsv CPerlObj::Perl_newSVsv #undef newSVpvf #define newSVpvf CPerlObj::Perl_newSVpvf +#undef newSVpvn +#define newSVpvn CPerlObj::Perl_newSVpvn #undef newUNOP #define newUNOP CPerlObj::Perl_newUNOP #undef newWHILEOP @@ -1007,6 +1011,10 @@ #define regtry CPerlObj::regtry #undef repeatcpy #define repeatcpy CPerlObj::Perl_repeatcpy +#undef restore_expect +#define restore_expect CPerlObj::restore_expect +#undef restore_lex_expect +#define restore_lex_expect CPerlObj::restore_lex_expect #undef restore_magic #define restore_magic CPerlObj::restore_magic #undef restore_rsfp @@ -1203,12 +1211,20 @@ #define sv_bless CPerlObj::Perl_sv_bless #undef sv_catpv #define sv_catpv CPerlObj::Perl_sv_catpv +#undef sv_catpv_mg +#define sv_catpv_mg CPerlObj::Perl_sv_catpv_mg #undef sv_catpvf #define sv_catpvf CPerlObj::Perl_sv_catpvf +#undef sv_catpvf_mg +#define sv_catpvf_mg CPerlObj::Perl_sv_catpvf_mg #undef sv_catpvn #define sv_catpvn CPerlObj::Perl_sv_catpvn +#undef sv_catpvn_mg +#define sv_catpvn_mg CPerlObj::Perl_sv_catpvn_mg #undef sv_catsv #define sv_catsv CPerlObj::Perl_sv_catsv +#undef sv_catsv_mg +#define sv_catsv_mg CPerlObj::Perl_sv_catsv_mg #undef sv_check_thinkfirst #define sv_check_thinkfirst CPerlObj::sv_check_thinkfirst #undef sv_chop @@ -1283,10 +1299,16 @@ #define sv_reset CPerlObj::Perl_sv_reset #undef sv_setiv #define sv_setiv CPerlObj::Perl_sv_setiv +#undef sv_setiv_mg +#define sv_setiv_mg CPerlObj::Perl_sv_setiv_mg #undef sv_setnv #define sv_setnv CPerlObj::Perl_sv_setnv +#undef sv_setnv_mg +#define sv_setnv_mg CPerlObj::Perl_sv_setnv_mg #undef sv_setuv #define sv_setuv CPerlObj::Perl_sv_setuv +#undef sv_setuv_mg +#define sv_setuv_mg CPerlObj::Perl_sv_setuv_mg #undef sv_setref_iv #define sv_setref_iv CPerlObj::Perl_sv_setref_iv #undef sv_setref_nv @@ -1297,14 +1319,24 @@ #define sv_setref_pvn CPerlObj::Perl_sv_setref_pvn #undef sv_setpv #define sv_setpv CPerlObj::Perl_sv_setpv +#undef sv_setpv_mg +#define sv_setpv_mg CPerlObj::Perl_sv_setpv_mg #undef sv_setpvf #define sv_setpvf CPerlObj::Perl_sv_setpvf +#undef sv_setpvf_mg +#define sv_setpvf_mg CPerlObj::Perl_sv_setpvf_mg #undef sv_setpviv #define sv_setpviv CPerlObj::Perl_sv_setpviv +#undef sv_setpviv_mg +#define sv_setpviv_mg CPerlObj::Perl_sv_setpviv_mg #undef sv_setpvn #define sv_setpvn CPerlObj::Perl_sv_setpvn +#undef sv_setpvn_mg +#define sv_setpvn_mg CPerlObj::Perl_sv_setpvn_mg #undef sv_setsv #define sv_setsv CPerlObj::Perl_sv_setsv +#undef sv_setsv_mg +#define sv_setsv_mg CPerlObj::Perl_sv_setsv_mg #undef sv_taint #define sv_taint CPerlObj::Perl_sv_taint #undef sv_tainted @@ -1323,6 +1355,8 @@ #define sv_upgrade CPerlObj::Perl_sv_upgrade #undef sv_usepvn #define sv_usepvn CPerlObj::Perl_sv_usepvn +#undef sv_usepvn_mg +#define sv_usepvn_mg CPerlObj::Perl_sv_usepvn_mg #undef sv_uv #define sv_uv CPerlObj::Perl_sv_uv #undef sv_vcatpvfn diff --git a/proto.h b/proto.h index b82db6a..a67d1e1 100644 --- a/proto.h +++ b/proto.h @@ -90,10 +90,10 @@ VIRTUAL char ** get_op_names _((void)); VIRTUAL I32 cxinc _((void)); void deb _((const char* pat,...)) __attribute__((format(printf,1,2))); void deb_growlevel _((void)); -I32 debop _((OP* o)); I32 debstackptrs _((void)); #ifdef DEBUGGING void debprofdump _((void)); +I32 debop _((OP* o)); #endif I32 debstack _((void)); VIRTUAL char* delimcpy _((char* to, char* toend, char* from, char* fromend, @@ -137,7 +137,9 @@ VIRTUAL void do_vecset _((SV* sv)); VIRTUAL void do_vop _((I32 optype, SV* sv, SV* left, SV* right)); VIRTUAL I32 dowantarray _((void)); VIRTUAL void dump_all _((void)); -VIRTUAL void dump_eval _((void)); +#ifdef DEBUGGING +void dump_eval _((void)); +#endif #ifdef DUMP_FDS /* See util.c */ int dump_fds _((char* s)); #endif @@ -438,12 +440,16 @@ VIRTUAL void push_scope _((void)); VIRTUAL regexp* pregcomp _((char* exp, char* xend, PMOP* pm)); VIRTUAL OP* ref _((OP* o, I32 type)); VIRTUAL OP* refkids _((OP* o, I32 type)); -VIRTUAL void regdump _((regexp* r)); +#ifdef DEBUGGING +void regdump _((regexp* r)); +#endif VIRTUAL I32 pregexec _((regexp* prog, char* stringarg, char* strend, char* strbeg, I32 minend, SV* screamer, U32 nosave)); VIRTUAL I32 regexec_flags _((regexp* prog, char* stringarg, char* strend, char* strbeg, I32 minend, SV* screamer, void* data, U32 flags)); VIRTUAL void pregfree _((struct regexp* r)); VIRTUAL regnode*regnext _((regnode* p)); -VIRTUAL void regprop _((SV* sv, regnode* o)); +#ifdef DEBUGGING +void regprop _((SV* sv, regnode* o)); +#endif VIRTUAL void repeatcpy _((char* to, char* from, I32 len, I32 count)); VIRTUAL char* rninstr _((char* big, char* bigend, char* little, char* lend)); VIRTUAL Sighandler_t rsignal _((int, Sighandler_t)); @@ -562,7 +568,9 @@ VIRTUAL void sv_magic _((SV* sv, SV* obj, int how, char* name, I32 namlen)); VIRTUAL SV* sv_mortalcopy _((SV* oldsv)); VIRTUAL SV* sv_newmortal _((void)); VIRTUAL SV* sv_newref _((SV* sv)); -VIRTUAL char* sv_peek _((SV* sv)); +#ifdef DEBUGGING +char* sv_peek _((SV* sv)); +#endif VIRTUAL char* sv_pvn_force _((SV* sv, STRLEN* lp)); VIRTUAL char* sv_reftype _((SV* sv, int ob)); VIRTUAL void sv_replace _((SV* sv, SV* nsv)); @@ -608,7 +616,9 @@ VIRTUAL void vivify_defelem _((SV* sv)); VIRTUAL void vivify_ref _((SV* sv, U32 to_what)); VIRTUAL I32 wait4pid _((int pid, int* statusp, int flags)); VIRTUAL void warn _((const char* pat,...)); -VIRTUAL void watch _((char** addr)); +#ifdef DEBUGGING +void watch _((char** addr)); +#endif VIRTUAL I32 whichsig _((char* sig)); VIRTUAL int yyerror _((char* s)); VIRTUAL int yylex _((void)); @@ -662,11 +672,29 @@ void del_xrv _((XRV* p)); void sv_mortalgrow _((void)); void sv_unglob _((SV* sv)); void sv_check_thinkfirst _((SV *sv)); + +SV *newSVpvn _((char *s, STRLEN len)); + +void sv_catpv_mg _((SV *sv, char *ptr)); +void sv_catpvf_mg _((SV *sv, const char* pat, ...)); +void sv_catpvn_mg _((SV *sv, char *ptr, STRLEN len)); +void sv_catsv_mg _((SV *dstr, SV *sstr)); +void sv_setiv_mg _((SV *sv, IV i)); +void sv_setnv_mg _((SV *sv, double num)); +void sv_setsv_mg _((SV *dstr, SV *sstr)); +void sv_setuv_mg _((SV *sv, UV u)); +void sv_setpv_mg _((SV *sv, const char *ptr)); +void sv_setpvf_mg _((SV *sv, const char* pat, ...)); +void sv_setpviv_mg _((SV *sv, IV iv)); +void sv_setpvn_mg _((SV *sv, const char *ptr, STRLEN len)); +void sv_usepvn_mg _((SV *sv, char *ptr, STRLEN len)); + void do_report_used _((SV *sv)); void do_clean_objs _((SV *sv)); void do_clean_named_objs _((SV *sv)); void do_clean_all _((SV *sv)); void not_a_number _((SV *sv)); +void* my_safemalloc _((MEM_SIZE size)); typedef void (CPerlObj::*SVFUNC) _((SV*)); void visit _((SVFUNC f)); @@ -785,7 +813,6 @@ void regset _((char *, I32)); void regtail _((regnode *, regnode *)); char* nextchar _((void)); regnode *dumpuntil _((regnode *start, regnode *node, regnode *last, SV* sv, I32 l)); -void debprof _((OP *o)); void scan_commit _((scan_data_t *data)); I32 study_chunk _((regnode **scanp, I32 *deltap, regnode *last, scan_data_t *data, U32 flags)); I32 add_data _((I32 n, char *s)); @@ -805,6 +832,7 @@ void BootDynaLoader(void); #ifdef DEBUGGING void del_sv _((SV *p)); +void debprof _((OP *o)); #endif #define PPDEF(s) OP* CPerlObj::s _((ARGSproto)); diff --git a/sv.c b/sv.c index 7562c12..823235e 100644 --- a/sv.c +++ b/sv.c @@ -585,7 +585,7 @@ more_xpv(void) # define my_safemalloc(s) safemalloc(s) # define my_safefree(s) free(s) #else -static void* +STATIC void* my_safemalloc(MEM_SIZE size) { char *p; @@ -3524,9 +3524,7 @@ newSVpv(char *s, STRLEN len) } SV * -newSVpvn(s,len) -char *s; -STRLEN len; +newSVpvn(char *s, STRLEN len) { register SV *sv; diff --git a/win32/dl_win32.xs b/win32/dl_win32.xs index f25a30f..077fb22 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 9033b55..5939c11 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 d95c692..795b901 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 aa0fe34..52be7f6 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 5cacb83..b7f61a2 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 8d6b041..31aadf9 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