diff options
| -rw-r--r-- | ObjXSub.h | 202 | ||||
| -rw-r--r-- | XSLock.h | 35 | ||||
| -rw-r--r-- | XSUB.h | 7 | ||||
| -rw-r--r-- | av.c | 6 | ||||
| -rw-r--r-- | embedvar.h | 3 | ||||
| -rw-r--r-- | ext/DynaLoader/dlutils.c | 4 | ||||
| -rw-r--r-- | globals.c | 14 | ||||
| -rw-r--r-- | ipstdio.h | 3 | ||||
| -rw-r--r-- | mg.c | 60 | ||||
| -rw-r--r-- | mg.h | 4 | ||||
| -rw-r--r-- | objpp.h | 16 | ||||
| -rw-r--r-- | perl.c | 11 | ||||
| -rw-r--r-- | perl.h | 8 | ||||
| -rw-r--r-- | perlio.h | 3 | ||||
| -rw-r--r-- | perlvars.h | 2 | ||||
| -rw-r--r-- | perly.c | 12 | ||||
| -rw-r--r-- | pp.c | 4 | ||||
| -rw-r--r-- | pp_ctl.c | 36 | ||||
| -rw-r--r-- | pp_hot.c | 8 | ||||
| -rw-r--r-- | proto.h | 15 | ||||
| -rw-r--r-- | regexec.c | 2 | ||||
| -rw-r--r-- | scope.c | 4 | ||||
| -rw-r--r-- | scope.h | 4 | ||||
| -rw-r--r-- | sv.c | 22 | ||||
| -rw-r--r-- | toke.c | 12 | ||||
| -rw-r--r-- | universal.c | 4 | ||||
| -rw-r--r-- | util.c | 2 | ||||
| -rw-r--r-- | win32/dl_win32.xs | 13 | ||||
| -rw-r--r-- | win32/iplio.c | 66 | ||||
| -rw-r--r-- | win32/ipstdio.c | 32 | ||||
| -rw-r--r-- | win32/perlobj.def | 2 | ||||
| -rw-r--r-- | win32/runperl.c | 8 |
32 files changed, 451 insertions, 173 deletions
@@ -10,12 +10,20 @@ #define gid pPerl->Perl_gid #undef egid #define egid pPerl->Perl_egid +#undef endav +#define endav pPerl->Perl_endav #undef an #define an pPerl->Perl_an +#undef compcv +#define compcv pPerl->Perl_compcv #undef cop_seqmax #define cop_seqmax pPerl->Perl_cop_seqmax +#undef defstash +#define defstash pPerl->Perl_defstash #undef evalseq #define evalseq pPerl->Perl_evalseq +#undef hexdigit +#define hexdigit pPerl->Perl_hexdigit #undef sub_generation #define sub_generation pPerl->Perl_sub_generation #undef origenviron @@ -68,14 +76,16 @@ #define markstack_ptr pPerl->Perl_markstack_ptr #undef markstack_max #define markstack_max pPerl->Perl_markstack_max +#undef maxo +#define maxo pPerl->Perl_maxo +#undef op_mask +#define op_mask pPerl->Perl_op_mask #undef curpad #define curpad pPerl->Perl_curpad #undef Sv #define Sv pPerl->Perl_Sv #undef Xpv #define Xpv pPerl->Perl_Xpv -#undef buf -#define buf pPerl->Perl_buf #undef tokenbuf #define tokenbuf pPerl->Perl_tokenbuf #undef statbuf @@ -330,6 +340,10 @@ #define gen_constant_list pPerl->Perl_gen_constant_list #undef getlogin #define getlogin pPerl->getlogin +#undef get_op_descs +#define get_op_descs pPerl->Perl_get_op_descs +#undef get_op_names +#define get_op_names pPerl->Perl_get_op_names #undef gp_free #define gp_free pPerl->Perl_gp_free #undef gp_ref @@ -540,8 +554,6 @@ #define mg_free pPerl->Perl_mg_free #undef mg_get #define mg_get pPerl->Perl_mg_get -#undef mg_Len -#define mg_Len pPerl->mg_Len #undef mg_magical #define mg_magical pPerl->Perl_mg_magical #undef mg_set @@ -848,6 +860,8 @@ #define save_clearsv pPerl->Perl_save_clearsv #undef save_delete #define save_delete pPerl->Perl_save_delete +#undef save_destructor +#define save_destructor pPerl->Perl_save_destructor #undef save_freesv #define save_freesv pPerl->Perl_save_freesv #undef save_freeop @@ -926,10 +940,6 @@ #define sighandler pPerl->Perl_sighandler #undef skipspace #define skipspace pPerl->Perl_skipspace -#undef sortcv -#define sortcv pPerl->sortcv -#undef sortcmp -#define sortcmp pPerl->sortcmp #undef stack_grow #define stack_grow pPerl->Perl_stack_grow #undef start_subparse @@ -1064,18 +1074,184 @@ #define warn pPerl->Perl_warn +#undef piMem +#define piMem (pPerl->piMem) +#undef piENV +#define piENV (pPerl->piENV) +#undef piStdIO +#define piStdIO (pPerl->piStdIO) +#undef piLIO +#define piLIO (pPerl->piLIO) +#undef piDir +#define piDir (pPerl->piDir) +#undef piSock +#define piSock (pPerl->piSock) +#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 +#undef stdin +#undef stdout +#undef stderr +#undef feof +#undef ferror +#undef fgetpos +#undef ioctl +#undef getlogin +#undef setjmp + +#define mkdir PerlDir_mkdir +#define chdir PerlDir_chdir +#define rmdir PerlDir_rmdir +#define closedir PerlDir_close +#define opendir PerlDir_open +#define readdir PerlDir_read +#define rewinddir PerlDir_rewind +#define seekdir PerlDir_seek +#define telldir PerlDir_tell +#define putenv PerlEnv_putenv +#define getenv PerlEnv_getenv +#define stdin PerlIO_stdin +#define stdout PerlIO_stdout +#define stderr PerlIO_stderr +#define fopen PerlIO_open +#define fclose PerlIO_close +#define feof PerlIO_eof +#define ferror PerlIO_error +#define fclearerr PerlIO_clearerr +#define getc PerlIO_getc +#define fputc(c, f) PerlIO_putc(f,c) +#define fputs(s, f) PerlIO_puts(f,s) +#define fflush PerlIO_flush +#define ungetc(c, f) PerlIO_ungetc((f),(c)) +#define fileno PerlIO_fileno +#define fdopen PerlIO_fdopen +#define freopen PerlIO_reopen +#define fread(b,s,c,f) PerlIO_read((f),(b),(s*c)) +#define fwrite(b,s,c,f) PerlIO_write((f),(b),(s*c)) +#define setbuf PerlIO_setbuf +#define setvbuf PerlIO_setvbuf +#define setlinebuf PerlIO_setlinebuf +#define stdoutf PerlIO_stdoutf +#define vfprintf PerlIO_vprintf +#define ftell PerlIO_tell +#define fseek PerlIO_seek +#define fgetpos PerlIO_getpos +#define fsetpos PerlIO_setpos +#define frewind PerlIO_rewind +#define tmpfile PerlIO_tmpfile +#define access PerlLIO_access +#define chmod PerlLIO_chmod +#define chsize PerlLIO_chsize +#define close PerlLIO_close +#define dup PerlLIO_dup +#define dup2 PerlLIO_dup2 +#define flock PerlLIO_flock +#define fstat PerlLIO_fstat +#define ioctl PerlLIO_ioctl +#define isatty PerlLIO_isatty +#define lseek PerlLIO_lseek +#define lstat PerlLIO_lstat +#define mktemp PerlLIO_mktemp +#define open PerlLIO_open +#define read PerlLIO_read +#define rename PerlLIO_rename +#define setmode PerlLIO_setmode +#define stat PerlLIO_stat +#define tmpnam PerlLIO_tmpnam +#define umask PerlLIO_umask +#define unlink PerlLIO_unlink +#define utime PerlLIO_utime +#define write PerlLIO_write +#define malloc PerlMem_malloc +#define realloc PerlMem_realloc +#define free PerlMem_free +#define abort PerlProc_abort +#define exit PerlProc_exit +#define _exit PerlProc__exit +#define execl PerlProc_execl +#define execv PerlProc_execv +#define execvp PerlProc_execvp +#define getuid PerlProc_getuid +#define geteuid PerlProc_geteuid +#define getgid PerlProc_getgid +#define getegid PerlProc_getegid +#define getlogin PerlProc_getlogin +#define kill PerlProc_kill +#define killpg PerlProc_killpg +#define pause PerlProc_pause +#define popen PerlProc_popen +#define pclose PerlProc_pclose +#define pipe PerlProc_pipe +#define setuid PerlProc_setuid +#define setgid PerlProc_setgid +#define sleep PerlProc_sleep +#define times PerlProc_times +#define wait PerlProc_wait +#define setjmp PerlProc_setjmp +#define longjmp PerlProc_longjmp +#define signal PerlProc_signal +#define htonl PerlSock_htonl +#define htons PerlSock_htons +#define ntohs PerlSock_ntohl +#define ntohl PerlSock_ntohs +#define accept PerlSock_accept +#define bind PerlSock_bind +#define connect PerlSock_connect +#define endhostent PerlSock_endhostent +#define endnetent PerlSock_endnetent +#define endprotoent PerlSock_endprotoent +#define endservent PerlSock_endservent +#define gethostbyaddr PerlSock_gethostbyaddr +#define gethostbyname PerlSock_gethostbyname +#define gethostent PerlSock_gethostent +#define gethostname PerlSock_gethostname +#define getnetbyaddr PerlSock_getnetbyaddr +#define getnetbyname PerlSock_getnetbyname +#define getnetent PerlSock_getnetent +#define getpeername PerlSock_getpeername +#define getprotobyname PerlSock_getprotobyname +#define getprotobynumber PerlSock_getprotobynumber +#define getprotoent PerlSock_getprotoent +#define getservbyname PerlSock_getservbyname +#define getservbyport PerlSock_getservbyport +#define getservent PerlSock_getservent +#define getsockname PerlSock_getsockname +#define getsockopt PerlSock_getsockopt +#define inet_addr PerlSock_inet_addr +#define inet_ntoa PerlSock_inet_ntoa +#define listen PerlSock_listen +#define recvfrom PerlSock_recvfrom +#define select PerlSock_select +#define send PerlSock_send +#define sendto PerlSock_sendto +#define sethostent PerlSock_sethostent +#define setnetent PerlSock_setnetent +#define setprotoent PerlSock_setprotoent +#define setservent PerlSock_setservent +#define setsockopt PerlSock_setsockopt +#define shutdown PerlSock_shutdown +#define socket PerlSock_socket +#define socketpair PerlSock_socketpair +#endif /* NO_XSLOCKS */ + +#undef THIS +#define THIS pPerl +#undef THIS_ +#define THIS_ pPerl, + #ifdef WIN32 #undef errno -#define errno pPerl->ErrorNo() -#undef pVtbl -#define pVtbl (pPerl->GetpVtbl()) -#undef g_lpObj -#define g_lpObj pPerl->Perl_g_lpObj +#define errno ErrorNo() +#undef ErrorNo +#define ErrorNo pPerl->ErrorNo #undef LastOLEError #define LastOLEError pPerl->Perl_LastOLEError #undef bOleInit diff --git a/XSLock.h b/XSLock.h new file mode 100644 index 0000000000..652f4929f1 --- /dev/null +++ b/XSLock.h @@ -0,0 +1,35 @@ +#ifndef __XSLock_h__ +#define __XSLock_h__ + +class XSLockManager +{ +public: + XSLockManager() { InitializeCriticalSection(&cs); }; + ~XSLockManager() { DeleteCriticalSection(&cs); }; + void Enter(void) { EnterCriticalSection(&cs); }; + void Leave(void) { LeaveCriticalSection(&cs); }; +protected: + CRITICAL_SECTION cs; +}; + +XSLockManager g_XSLock; + +class XSLock +{ +public: + XSLock() { g_XSLock.Enter(); }; + ~XSLock() { g_XSLock.Leave(); }; +}; + +CPerlObj* pPerl; + +#undef dXSARGS +#define dXSARGS \ + dSP; dMARK; \ + I32 ax = mark - stack_base + 1; \ + I32 items = sp - mark; \ + XSLock localLock; \ + ::pPerl = pPerl + + +#endif @@ -76,4 +76,9 @@ #ifdef PERL_OBJECT #include "ObjXSub.h" -#endif
\ No newline at end of file +#ifndef NO_XSLOCKS +#ifdef WIN32 +#include "XSLock.h" +#endif /* WIN32 */ +#endif /* NO_XSLOCKS */ +#endif /* PERL_OBJECT */ @@ -367,7 +367,13 @@ av_undef(register AV *av) SvREFCNT_dec(AvARRAY(av)[--key]); } Safefree(AvALLOC(av)); +#ifdef PERL_OBJECT + (((XPVAV*) SvANY(av))->xav_array) = 0; + /* the following line is is a problem with VC */ + /* AvARRAY(av) = 0; */ +#else AvARRAY(av) = 0; +#endif AvALLOC(av) = 0; SvPVX(av) = 0; AvMAX(av) = AvFILLp(av) = -1; diff --git a/embedvar.h b/embedvar.h index 5d3e1d19c7..7f3dce022c 100644 --- a/embedvar.h +++ b/embedvar.h @@ -707,7 +707,6 @@ #define scrgv (Perl_Vars.Gscrgv) #define sh_path (Perl_Vars.Gsh_path) #define sighandlerp (Perl_Vars.Gsighandlerp) -#define sort_mutex (Perl_Vars.Gsort_mutex) #define sub_generation (Perl_Vars.Gsub_generation) #define subline (Perl_Vars.Gsubline) #define subname (Perl_Vars.Gsubname) @@ -827,7 +826,6 @@ #define Gscrgv scrgv #define Gsh_path sh_path #define Gsighandlerp sighandlerp -#define Gsort_mutex sort_mutex #define Gsub_generation sub_generation #define Gsubline subline #define Gsubname subname @@ -947,7 +945,6 @@ #define scrgv Perl_scrgv #define sh_path Perl_sh_path #define sighandlerp Perl_sighandlerp -#define sort_mutex Perl_sort_mutex #define sub_generation Perl_sub_generation #define subline Perl_subline #define subname Perl_subname diff --git a/ext/DynaLoader/dlutils.c b/ext/DynaLoader/dlutils.c index 422b3d1bf9..f7c630aacf 100644 --- a/ext/DynaLoader/dlutils.c +++ b/ext/DynaLoader/dlutils.c @@ -26,7 +26,7 @@ static int dl_debug = 0; /* value copied from $DynaLoader::dl_error */ static void -dl_generic_private_init(void) /* called by dl_*.xs dl_private_init() */ +dl_generic_private_init(CPERLarg) /* called by dl_*.xs dl_private_init() */ { char *perl_dl_nonlazy; #ifdef DEBUGGING @@ -45,7 +45,7 @@ dl_generic_private_init(void) /* called by dl_*.xs dl_private_init() */ /* SaveError() takes printf style args and saves the result in LastError */ static void -SaveError(char* pat, ...) +SaveError(CPERLarg_ char* pat, ...) { va_list args; char *message; @@ -1435,14 +1435,11 @@ CPerlObj::Init(void) curcop = &compiling; cxstack_ix = -1; cxstack_max = 128; + chopset = " \n-"; #ifdef USE_THREADS threadsv_names = THREADSV_NAMES; - chopset = " \n-"; tmps_ix = -1; tmps_floor = -1; - curcop = &compiling; - cxstack_ix = -1; - cxstack_max = 128; #endif maxo = MAXO; sh_path = SH_PATH; @@ -1497,6 +1494,15 @@ do_aspawn(void *vreally, void **vmark, void **vsp) return PerlProc_aspawn(vreally, vmark, vsp); } +EXTERN_C void boot_DynaLoader _((CPERLarg_ CV* cv)); + +void CPerlObj::BootDynaLoader(void) +{ + char *file = __FILE__; + dXSUB_SYS; + newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file); +} + #endif /* WIN32 */ #endif /* PERL_OBJECT */ @@ -34,8 +34,11 @@ public: virtual int Ungetc(PerlIO*,int, int &err) = 0; virtual int Fileno(PerlIO*, int &err) = 0; virtual PerlIO* Fdopen(int, const char *, int &err) = 0; + virtual PerlIO* Reopen(const char*, const char*, PerlIO*, int &err) = 0; virtual SSize_t Read(PerlIO*,void *,Size_t, int &err) = 0; virtual SSize_t Write(PerlIO*,const void *,Size_t, int &err) = 0; + virtual void SetBuf(PerlIO *, char*, int &err) = 0; + virtual int SetVBuf(PerlIO *, char*, int, Size_t, int &err) = 0; virtual void SetCnt(PerlIO *, int, int &err) = 0; virtual void SetPtrCnt(PerlIO *, char *, int, int& err) = 0; virtual void Setlinebuf(PerlIO*, int &err) = 0; @@ -31,17 +31,7 @@ */ #ifdef PERL_OBJECT -static void UnwindHandler(void *pPerl, void *ptr) -{ - ((CPerlObj*)pPerl)->unwind_handler_stack(ptr); -} -static void RestoreMagic(void *pPerl, void *ptr) -{ - ((CPerlObj*)pPerl)->restore_magic(ptr); -} -#define UNWINDHANDLER UnwindHandler -#define RESTOREMAGIC RestoreMagic #define VTBL this->*vtbl #else @@ -52,8 +42,6 @@ struct magic_state { typedef struct magic_state MGS; static void restore_magic _((void *p)); -#define UNWINDHANDLER unwind_handler_stack -#define RESTOREMAGIC restore_magic #define VTBL *vtbl #endif @@ -65,7 +53,7 @@ save_magic(MGS *mgs, SV *sv) mgs->mgs_sv = sv; mgs->mgs_flags = SvMAGICAL(sv) | SvREADONLY(sv); - SAVEDESTRUCTOR(RESTOREMAGIC, mgs); + SAVEDESTRUCTOR(restore_magic, mgs); SvMAGICAL_off(sv); SvREADONLY_off(sv); @@ -166,7 +154,7 @@ mg_set(SV *sv) } U32 -mg_len(SV *sv) +mg_length(SV *sv) { MAGIC* mg; char *junk; @@ -198,11 +186,11 @@ mg_size(SV *sv) for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { MGVTBL* vtbl = mg->mg_virtual; - if (vtbl && vtbl->svt_len) { + if (vtbl && (vtbl->svt_len != NULL)) { MGS mgs; ENTER; /* omit MGf_GSKIP -- not changed here */ - len = (*vtbl->svt_len)(sv, mg); + len = (VTBL->svt_len)(sv, mg); LEAVE; return len; } @@ -278,9 +266,9 @@ mg_free(SV *sv) if (vtbl && (vtbl->svt_free != NULL)) (VTBL->svt_free)(sv, mg); if (mg->mg_ptr && mg->mg_type != 'g') - if (mg->mg_length >= 0) + if (mg->mg_len >= 0) Safefree(mg->mg_ptr); - else if (mg->mg_length == HEf_SVKEY) + else if (mg->mg_len == HEf_SVKEY) SvREFCNT_dec((SV*)mg->mg_ptr); if (mg->mg_flags & MGf_REFCOUNTED) SvREFCNT_dec(mg->mg_obj); @@ -984,7 +972,7 @@ magic_setnkeys(SV *sv, MAGIC *mg) return 0; } -static int +STATIC int magic_methcall(MAGIC *mg, char *meth, I32 flags, int n, SV *val) { dSP; @@ -994,13 +982,13 @@ magic_methcall(MAGIC *mg, char *meth, I32 flags, int n, SV *val) PUSHs(mg->mg_obj); if (n > 1) { if (mg->mg_ptr) { - if (mg->mg_length >= 0) - PUSHs(sv_2mortal(newSVpv(mg->mg_ptr, mg->mg_length))); - else if (mg->mg_length == HEf_SVKEY) + if (mg->mg_len >= 0) + PUSHs(sv_2mortal(newSVpv(mg->mg_ptr, mg->mg_len))); + else if (mg->mg_len == HEf_SVKEY) PUSHs((SV*)mg->mg_ptr); } else if (mg->mg_type == 'p') { - PUSHs(sv_2mortal(newSViv(mg->mg_length))); + PUSHs(sv_2mortal(newSViv(mg->mg_len))); } } if (n > 2) { @@ -1155,9 +1143,9 @@ magic_getpos(SV *sv, MAGIC *mg) if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) { mg = mg_find(lsv, 'g'); - if (mg && mg->mg_length >= 0) { + if (mg && mg->mg_len >= 0) { dTHR; - sv_setiv(sv, mg->mg_length + curcop->cop_arybase); + sv_setiv(sv, mg->mg_len + curcop->cop_arybase); return 0; } } @@ -1183,7 +1171,7 @@ magic_setpos(SV *sv, MAGIC *mg) mg = mg_find(lsv, 'g'); } else if (!SvOK(sv)) { - mg->mg_length = -1; + mg->mg_len = -1; return 0; } len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv); @@ -1196,7 +1184,7 @@ magic_setpos(SV *sv, MAGIC *mg) } else if (pos > len) pos = len; - mg->mg_length = pos; + mg->mg_len = pos; mg->mg_flags &= ~MGf_MINMATCH; return 0; @@ -1248,8 +1236,8 @@ int magic_gettaint(SV *sv, MAGIC *mg) { dTHR; - TAINT_IF((mg->mg_length & 1) || - (mg->mg_length & 2) && mg->mg_obj == sv); /* kludge */ + TAINT_IF((mg->mg_len & 1) || + (mg->mg_len & 2) && mg->mg_obj == sv); /* kludge */ return 0; } @@ -1259,14 +1247,14 @@ magic_settaint(SV *sv, MAGIC *mg) dTHR; if (localizing) { if (localizing == 1) - mg->mg_length <<= 1; + mg->mg_len <<= 1; else - mg->mg_length >>= 1; + mg->mg_len >>= 1; } else if (tainted) - mg->mg_length |= 1; + mg->mg_len |= 1; else - mg->mg_length &= ~1; + mg->mg_len &= ~1; return 0; } @@ -1366,7 +1354,7 @@ vivify_defelem(SV *sv) int magic_setmglob(SV *sv, MAGIC *mg) { - mg->mg_length = -1; + mg->mg_len = -1; SvSCREAM_off(sv); return 0; } @@ -1416,7 +1404,7 @@ magic_setcollxfrm(SV *sv, MAGIC *mg) if (mg->mg_ptr) { Safefree(mg->mg_ptr); mg->mg_ptr = NULL; - mg->mg_length = -1; + mg->mg_len = -1; } return 0; } @@ -1866,7 +1854,7 @@ sighandler(int sig) if (flags & 1) { savestack_ix += 5; /* Protect save in progress. */ o_save_i = savestack_ix; - SAVEDESTRUCTOR(UNWINDHANDLER, (void*)&flags); + SAVEDESTRUCTOR(unwind_handler_stack, (void*)&flags); } if (flags & 4) markstack_ptr++; /* Protect mark. */ @@ -23,7 +23,7 @@ struct magic { U8 mg_flags; SV* mg_obj; char* mg_ptr; - I32 mg_length; + I32 mg_len; }; #define MGf_TAINTEDDIR 1 @@ -36,6 +36,6 @@ struct magic { #define MgTAINTEDDIR_on(mg) (mg->mg_flags |= MGf_TAINTEDDIR) #define MgTAINTEDDIR_off(mg) (mg->mg_flags &= ~MGf_TAINTEDDIR) -#define MgPV(mg,lp) (((lp = (mg)->mg_length) == HEf_SVKEY) ? \ +#define MgPV(mg,lp) (((lp = (mg)->mg_len) == HEf_SVKEY) ? \ SvPV((SV*)((mg)->mg_ptr),lp) : \ (mg)->mg_ptr) @@ -573,6 +573,8 @@ #define magic_getuvar CPerlObj::Perl_magic_getuvar #undef magic_len #define magic_len CPerlObj::Perl_magic_len +#undef magic_methcall +#define magic_methcall CPerlObj::magic_methcall #undef magic_methpack #define magic_methpack CPerlObj::magic_methpack #undef magic_nextpack @@ -619,6 +621,8 @@ #define magic_setuvar CPerlObj::Perl_magic_setuvar #undef magic_setvec #define magic_setvec CPerlObj::Perl_magic_setvec +#undef magic_sizepack +#define magic_sizepack CPerlObj::Perl_magic_sizepack #undef magic_wipepack #define magic_wipepack CPerlObj::Perl_magic_wipepack #undef magicname @@ -643,12 +647,14 @@ #define mg_free CPerlObj::Perl_mg_free #undef mg_get #define mg_get CPerlObj::Perl_mg_get -#undef mg_len -#define mg_len CPerlObj::Perl_mg_len +#undef mg_length +#define mg_length CPerlObj::mg_length #undef mg_magical #define mg_magical CPerlObj::Perl_mg_magical #undef mg_set #define mg_set CPerlObj::Perl_mg_set +#undef mg_size +#define mg_size CPerlObj::Perl_mg_size #undef missingterm #define missingterm CPerlObj::missingterm #undef mod @@ -929,6 +935,8 @@ #define push_scope CPerlObj::Perl_push_scope #undef pregcomp #define pregcomp CPerlObj::Perl_pregcomp +#undef qsortsv +#define qsortsv CPerlObj::qsortsv #undef ref #define ref CPerlObj::Perl_ref #undef refkids @@ -1153,10 +1161,6 @@ #define skipspace CPerlObj::Perl_skipspace #undef sortcv #define sortcv CPerlObj::sortcv -#undef sortcmp -#define sortcmp CPerlObj::sortcmp -#undef sortcmp_locale -#define sortcmp_locale CPerlObj::sortcmp_locale #ifndef PERL_OBJECT #undef stack_base #define stack_base CPerlObj::Perl_stack_base @@ -164,10 +164,6 @@ perl_construct(register PerlInterpreter *sv_interp) MUTEX_INIT(&threads_mutex); COND_INIT(&nthreads_cond); -#ifdef PERL_OBJECT - MUTEX_INIT(&sort_mutex); -#endif - thr = init_main_thread(); #endif /* USE_THREADS */ @@ -561,9 +557,6 @@ perl_destruct(register PerlInterpreter *sv_interp) hints = 0; /* Reset hints. Should hints be per-interpreter ? */ DEBUG_P(debprofdump()); -#ifdef PERL_OBJECT - MUTEX_DESTROY(&sort_mutex); -#endif #ifdef USE_THREADS MUTEX_DESTROY(&sv_mutex); MUTEX_DESTROY(&eval_mutex); @@ -596,6 +589,7 @@ perl_free(PerlInterpreter *sv_interp) #endif { #ifdef PERL_OBJECT + Safefree(this); #else if (!(curinterp = sv_interp)) return; @@ -946,6 +940,9 @@ print \" \\@INC:\\n @INC\\n\";"); CvPADLIST(compcv) = comppadlist; boot_core_UNIVERSAL(); +#if defined(WIN32) && defined(PERL_OBJECT) + BootDynaLoader(); +#endif if (xsinit) (*xsinit)(THIS); /* in case linked C routines want magical variables */ #if defined(VMS) || defined(WIN32) || defined(DJGPP) @@ -43,7 +43,7 @@ class CPerlObj; #define CPERLscope(x) x #define CPERLproto #define CPERLproto_ -#define CPERLarg +#define CPERLarg void #define CPERLarg_ #define THIS #define THIS_ @@ -1101,11 +1101,7 @@ union any { I32 any_i32; IV any_iv; long any_long; -#ifdef PERL_OBJECT - void (*any_dptr) _((void*, void*)); -#else - void (*any_dptr) _((void*)); -#endif + void (CPERLscope(*any_dptr)) _((void*)); }; #ifdef USE_THREADS @@ -48,8 +48,11 @@ extern void PerlIO_init _((void)); #define PerlIO_ungetc(f,c) piStdIO->Ungetc((f),(c), ErrorNo()) #define PerlIO_fileno(f) piStdIO->Fileno((f), ErrorNo()) #define PerlIO_fdopen(f, s) piStdIO->Fdopen((f),(s), ErrorNo()) +#define PerlIO_reopen(p, m, f) piStdIO->Reopen((p), (m), (f), ErrorNo()) #define PerlIO_read(f,buf,count) (SSize_t)piStdIO->Read((f), (buf), (count), ErrorNo()) #define PerlIO_write(f,buf,count) piStdIO->Write((f), (buf), (count), ErrorNo()) +#define PerlIO_setbuf(f,b) piStdIO->SetBuf((f), (b), ErrorNo()) +#define PerlIO_setvbuf(f,b,t,s) piStdIO->SetVBuf((f), (b), (t), (s), ErrorNo()) #define PerlIO_set_cnt(f,c) piStdIO->SetCnt((f), (c), ErrorNo()) #define PerlIO_set_ptrcnt(f,p,c) piStdIO->SetPtrCnt((f), (p), (c), ErrorNo()) #define PerlIO_setlinebuf(f) piStdIO->Setlinebuf((f), ErrorNo()) diff --git a/perlvars.h b/perlvars.h index ab335493d2..1faa80c0d1 100644 --- a/perlvars.h +++ b/perlvars.h @@ -25,8 +25,6 @@ PERLVAR(Gcurthr, struct perl_thread *) /* Currently executing (fake) thread */ #endif #endif /* USE_THREADS */ #ifdef PERL_OBJECT -/* TODO: move into thread section */ -PERLVAR(Gsort_mutex, CRITICAL_SECTION) /* Mutex for qsort */ #ifdef WIN32 PERLVAR(Gerror_no, int) /* errno for each interpreter */ #endif @@ -1326,16 +1326,6 @@ yydestruct(void *ptr) Safefree(ysave); } -#ifdef PERL_OBJECT -static void YYDestructor(void *pPerl, void *ptr) -{ - ((CPerlObj*)pPerl)->yydestruct(ptr); -} -#define YYDESTRUCT YYDestructor -#else -#define YYDESTRUCT yydestruct -#endif - int yyparse(void) { @@ -1354,7 +1344,7 @@ yyparse(void) #endif struct ysv *ysave = (struct ysv*)safemalloc(sizeof(struct ysv)); - SAVEDESTRUCTOR(YYDESTRUCT, ysave); + SAVEDESTRUCTOR(yydestruct, ysave); ysave->oldyydebug = yydebug; ysave->oldyynerrs = yynerrs; ysave->oldyyerrflag = yyerrflag; @@ -325,8 +325,8 @@ PP(pp_pos) if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { mg = mg_find(sv, 'g'); - if (mg && mg->mg_length >= 0) { - PUSHi(mg->mg_length + curcop->cop_arybase); + if (mg && mg->mg_len >= 0) { + PUSHi(mg->mg_len + curcop->cop_arybase); RETURN; } } @@ -637,15 +637,6 @@ PP(pp_mapwhile) } } - -#ifdef PERL_OBJECT -static CPerlObj *pSortPerl; -static int SortCv(const void *a, const void *b) -{ - return pSortPerl->sortcv(a, b); -} -#endif - PP(pp_sort) { djSP; dMARK; dORIGMARK; @@ -751,15 +742,7 @@ PP(pp_sort) (void)SvREFCNT_inc(cv); /* in preparation for POPSUB */ } sortcxix = cxstack_ix; - -#ifdef PERL_OBJECT - MUTEX_LOCK(&sort_mutex); - pSortPerl = this; - qsortsv((myorigmark+1), max, SortCv); - MUTEX_UNLOCK(&sort_mutex); -#else qsortsv((myorigmark+1), max, sortcv); -#endif POPBLOCK(cx,curpm); SWITCHSTACK(sortstack, oldstack); @@ -770,18 +753,8 @@ PP(pp_sort) else { if (max > 1) { MEXTEND(SP, 20); /* Can't afford stack realloc on signal. */ -#ifdef PERL_OBJECT - /* XXX sort_mutex is probably not needed since qsort is now - * internal GSAR */ - MUTEX_LOCK(&sort_mutex); - pSortPerl = this; qsortsv(ORIGMARK+1, max, (op->op_private & OPpLOCALE) ? sv_cmp_locale : sv_cmp); - MUTEX_UNLOCK(&sort_mutex); -#else - qsortsv(ORIGMARK+1, max, - (op->op_private & OPpLOCALE) ? sv_cmp_locale : sv_cmp); -#endif } } stack_sp = ORIGMARK + max; @@ -3017,8 +2990,13 @@ struct partition_stack_entry { /* Return < 0 == 0 or > 0 as the value of elt1 is < elt2, == elt2, > elt2 */ +#ifdef PERL_OBJECT +#define qsort_cmp(elt1, elt2) \ + ((this->*compare)(array[elt1], array[elt2])) +#else #define qsort_cmp(elt1, elt2) \ ((*compare)(array[elt1], array[elt2])) +#endif #ifdef QSORT_ORDER_GUESS #define QSORT_NOTICE_SWAP swapped++; @@ -3099,10 +3077,14 @@ doqsort_all_asserts( /* ****************************************************************** qsort */ void +#ifdef PERL_OBJECT +qsortsv(SV ** array, size_t num_elts, SVCOMPARE compare) +#else qsortsv( SV ** array, size_t num_elts, I32 (*compare)(SV *a, SV *b)) +#endif { register SV * temp; @@ -806,8 +806,8 @@ PP(pp_match) rx->startp[0] = 0; if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) { MAGIC* mg = mg_find(TARG, 'g'); - if (mg && mg->mg_length >= 0) { - rx->endp[0] = rx->startp[0] = s + mg->mg_length; + if (mg && mg->mg_len >= 0) { + rx->endp[0] = rx->startp[0] = s + mg->mg_len; minmatch = (mg->mg_flags & MGf_MINMATCH); update_minmatch = 0; } @@ -929,7 +929,7 @@ play_it_again: mg = mg_find(TARG, 'g'); } if (rx->startp[0]) { - mg->mg_length = rx->endp[0] - rx->subbeg; + mg->mg_len = rx->endp[0] - rx->subbeg; if (rx->startp[0] == rx->endp[0]) mg->mg_flags |= MGf_MINMATCH; else @@ -976,7 +976,7 @@ ret_no: if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) { MAGIC* mg = mg_find(TARG, 'g'); if (mg) - mg->mg_length = -1; + mg->mg_len = -1; } } LEAVE_SCOPE(oldsave); @@ -278,7 +278,7 @@ VIRTUAL int mg_copy _((SV* , SV* , char* , I32)); VIRTUAL MAGIC* mg_find _((SV* sv, int type)); VIRTUAL int mg_free _((SV* sv)); VIRTUAL int mg_get _((SV* sv)); -VIRTUAL U32 mg_len _((SV* sv)); +VIRTUAL U32 mg_length _((SV* sv)); VIRTUAL void mg_magical _((SV* sv)); VIRTUAL int mg_set _((SV* sv)); VIRTUAL I32 mg_size _((SV* sv)); @@ -344,7 +344,7 @@ VIRTUAL OP* newLISTOP _((I32 type, I32 flags, OP* first, OP* last)); VIRTUAL OP* newPMOP _((I32 type, I32 flags)); VIRTUAL OP* newPVOP _((I32 type, I32 flags, char* pv)); VIRTUAL SV* newRV _((SV* ref)); -#if !defined(__GNUC__) && (defined(CRIPPLED_CC) || defined(USE_THREADS)) +#if !defined(__GNUC__) && (defined(CRIPPLED_CC) || defined(USE_THREADS) || defined(PERL_OBJECT)) VIRTUAL SV* newRV_noinc _((SV *)); #endif #ifdef LEAKTEST @@ -465,7 +465,8 @@ VIRTUAL void save_clearsv _((SV** svp)); VIRTUAL void save_delete _((HV* hv, char* key, I32 klen)); #ifndef titan /* TitanOS cc can't handle this */ #ifdef PERL_OBJECT -VIRTUAL void save_destructor _((void (*f)(void*, void*), void* p)); +typedef void (CPerlObj::*DESTRUCTORFUNC) _((void*)); +VIRTUAL void save_destructor _((DESTRUCTORFUNC f, void* p)); #else void save_destructor _((void (*f)(void*), void* p)); #endif @@ -670,8 +671,12 @@ void not_a_number _((SV *sv)); typedef void (CPerlObj::*SVFUNC) _((SV*)); void visit _((SVFUNC f)); +typedef I32 (CPerlObj::*SVCOMPARE) _((SV*, SV*)); +void qsortsv _((SV ** array, size_t num_elts, SVCOMPARE f)); +I32 sortcv _((SV *a, SV *b)); void save_magic _((MGS *mgs, SV *sv)); int magic_methpack _((SV *sv, MAGIC *mg, char *meth)); +int magic_methcall _((MAGIC *mg, char *meth, I32 flags, int n, SV *val)); OP * doform _((CV *cv, GV *gv, OP *retop)); void doencodes _((SV* sv, char* s, I32 len)); SV* refto _((SV* sv)); @@ -795,6 +800,7 @@ char * regcppop _((void)); void dump _((char *pat,...)); #ifdef WIN32 int do_aspawn _((void *vreally, void **vmark, void **vsp)); +void BootDynaLoader(void); #endif #ifdef DEBUGGING @@ -1186,9 +1192,6 @@ void unwind_handler_stack _((void *p)); void restore_magic _((void *p)); void restore_rsfp _((void *f)); void yydestruct _((void *ptr)); -int sortcv _((const void *, const void *)); -int sortcmp _((const void *, const void *)); -int sortcmp_locale _((const void *, const void *)); VIRTUAL int fprintf _((PerlIO *, const char *, ...)); #ifdef WIN32 @@ -1580,7 +1580,7 @@ regmatch(regnode *prog) } if (OP(scan) == SUSPEND) { locinput = reginput; - nextchar = UCHARAT(locinput); + nextchr = UCHARAT(locinput); } /* FALL THROUGH. */ case LONGJMP: @@ -452,7 +452,7 @@ save_list(register SV **sarg, I32 maxsarg) void #ifdef PERL_OBJECT -save_destructor(void (*f) (void*, void*), void* p) +save_destructor(DESTRUCTORFUNC f, void* p) #else save_destructor(void (*f) (void *), void *p) #endif @@ -691,7 +691,7 @@ leave_scope(I32 base) break; case SAVEt_DESTRUCTOR: ptr = SSPOPPTR; - (*SSPOPDPTR)(THIS_ ptr); + (CALLDESTRUCTOR)(ptr); break; case SAVEt_REGCONTEXT: { @@ -61,9 +61,11 @@ #define SAVEDELETE(h,k,l) \ save_delete(SOFT_CAST(HV*)(h), SOFT_CAST(char*)(k), (I32)(l)) #ifdef PERL_OBJECT +#define CALLDESTRUCTOR this->*SSPOPDPTR #define SAVEDESTRUCTOR(f,p) \ - save_destructor(SOFT_CAST(void(*)_((void*, void*)))(f),SOFT_CAST(void*)(p)) + save_destructor((DESTRUCTORFUNC)(f),SOFT_CAST(void*)(p)) #else +#define CALLDESTRUCTOR *SSPOPDPTR #define SAVEDESTRUCTOR(f,p) \ save_destructor(SOFT_CAST(void(*)_((void*)))(f),SOFT_CAST(void*)(p)) #endif @@ -2353,7 +2353,7 @@ sv_magic(register SV *sv, SV *obj, int how, char *name, I32 namlen) if (SvMAGICAL(sv) || (how == 't' && SvTYPE(sv) >= SVt_PVMG)) { if (SvMAGIC(sv) && (mg = mg_find(sv, how))) { if (how == 't') - mg->mg_length |= 1; + mg->mg_len |= 1; return; } } @@ -2373,7 +2373,7 @@ sv_magic(register SV *sv, SV *obj, int how, char *name, I32 namlen) mg->mg_flags |= MGf_REFCOUNTED; } mg->mg_type = how; - mg->mg_length = namlen; + mg->mg_len = namlen; if (name) if (namlen >= 0) mg->mg_ptr = savepvn(name, namlen); @@ -2454,7 +2454,7 @@ sv_magic(register SV *sv, SV *obj, int how, char *name, I32 namlen) break; case 't': mg->mg_virtual = &vtbl_taint; - mg->mg_length = 1; + mg->mg_len = 1; break; case 'U': mg->mg_virtual = &vtbl_uvar; @@ -2506,9 +2506,9 @@ sv_unmagic(SV *sv, int type) if (vtbl && (vtbl->svt_free != NULL)) (VTBL->svt_free)(sv, mg); if (mg->mg_ptr && mg->mg_type != 'g') - if (mg->mg_length >= 0) + if (mg->mg_len >= 0) Safefree(mg->mg_ptr); - else if (mg->mg_length == HEf_SVKEY) + else if (mg->mg_len == HEf_SVKEY) SvREFCNT_dec((SV*)mg->mg_ptr); if (mg->mg_flags & MGf_REFCOUNTED) SvREFCNT_dec(mg->mg_obj); @@ -2833,7 +2833,7 @@ sv_len(register SV *sv) return 0; if (SvGMAGICAL(sv)) - len = mg_len(sv); + len = mg_length(sv); else junk = SvPV(sv, len); return len; @@ -2971,17 +2971,17 @@ sv_collxfrm(SV *sv, STRLEN *nxp) assert(mg); } mg->mg_ptr = xf; - mg->mg_length = xlen; + mg->mg_len = xlen; } else { if (mg) { mg->mg_ptr = NULL; - mg->mg_length = -1; + mg->mg_len = -1; } } } if (mg && mg->mg_ptr) { - *nxp = mg->mg_length; + *nxp = mg->mg_len; return mg->mg_ptr + sizeof(collation_ix); } else { @@ -4016,7 +4016,7 @@ sv_untaint(SV *sv) if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { MAGIC *mg = mg_find(sv, 't'); if (mg) - mg->mg_length &= ~1; + mg->mg_len &= ~1; } } @@ -4025,7 +4025,7 @@ sv_tainted(SV *sv) { if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { MAGIC *mg = mg_find(sv, 't'); - if (mg && ((mg->mg_length & 1) || (mg->mg_length & 2) && mg->mg_obj == sv)) + if (mg && ((mg->mg_len & 1) || (mg->mg_len & 2) && mg->mg_obj == sv)) return TRUE; } return FALSE; @@ -145,16 +145,6 @@ static struct { /* grandfather return to old style */ #define OLDLOP(f) return(yylval.ival=f,expect = XTERM,bufptr = s,(int)LSTOP) -#ifdef PERL_OBJECT -static void RestoreRsfp(void *pPerl, void *ptr) -{ - ((CPerlObj*)pPerl)->restore_rsfp(ptr); -} -#define RESTORERSFP RestoreRsfp -#else -#define RESTORERSFP restore_rsfp -#endif - STATIC int ao(int toketype) { @@ -268,7 +258,7 @@ lex_start(SV *line) SAVESPTR(linestr); SAVEPPTR(lex_brackstack); SAVEPPTR(lex_casestack); - SAVEDESTRUCTOR(RESTORERSFP, rsfp); + SAVEDESTRUCTOR(restore_rsfp, rsfp); lex_state = LEX_NORMAL; lex_defer = 0; diff --git a/universal.c b/universal.c index 18989aaf02..72da1e4937 100644 --- a/universal.c +++ b/universal.c @@ -100,6 +100,10 @@ sv_derived_from(SV *sv, char *name) } +#ifdef PERL_OBJECT +#define NO_XSLOCKS +#endif /* PERL_OBJECT */ + #include "XSUB.h" static @@ -2458,7 +2458,7 @@ condpair_magic(SV *sv) sv_magic(sv, Nullsv, 'm', 0, 0); mg = SvMAGIC(sv); mg->mg_ptr = (char *)cp; - mg->mg_length = sizeof(cp); + mg->mg_len = sizeof(cp); MUTEX_UNLOCK(&sv_mutex); DEBUG_L(WITH_THR(PerlIO_printf(PerlIO_stderr(), "%p: condpair_magic %p\n", thr, sv));) diff --git a/win32/dl_win32.xs b/win32/dl_win32.xs index 13d97211a3..f25a30f6ad 100644 --- a/win32/dl_win32.xs +++ b/win32/dl_win32.xs @@ -26,16 +26,24 @@ calls. #include "EXTERN.h" #include "perl.h" + +#ifdef PERL_OBJECT +#define NO_XSLOCKS +#endif /* PERL_OBJECT */ + #include "XSUB.h" #include "dlutils.c" /* SaveError() etc */ static void -dl_private_init(void) +dl_private_init(CPERLarg) { - (void)dl_generic_private_init(); + (void)dl_generic_private_init(THIS); } +#ifdef PERL_OBJECT +#define dl_static_linked(x) 0 +#else static int dl_static_linked(char *filename) { @@ -45,6 +53,7 @@ dl_static_linked(char *filename) }; return 0; } +#endif MODULE = DynaLoader PACKAGE = DynaLoader diff --git a/win32/iplio.c b/win32/iplio.c index 3522284219..2969126fd3 100644 --- a/win32/iplio.c +++ b/win32/iplio.c @@ -171,10 +171,7 @@ int CPerlLIO::Flock(int fd, int oper, int &err) int CPerlLIO::FStat(int fd, struct stat *sbufptr, int &err) { - int ret = fstat(fd, sbufptr); - if(errno) - err = errno; - return ret; + CALLFUNCERR(fstat(fd, sbufptr)) } int CPerlLIO::IOCtl(int i, unsigned int u, char *data, int &err) @@ -194,7 +191,7 @@ long CPerlLIO::Lseek(int fd, long offset, int origin, int &err) int CPerlLIO::Lstat(const char *path, struct stat *sbufptr, int &err) { - return stat(path, sbufptr); + return STat(path, sbufptr, err); } char *CPerlLIO::Mktemp(char *Template, int &err) @@ -204,12 +201,28 @@ char *CPerlLIO::Mktemp(char *Template, int &err) int CPerlLIO::Open(const char *filename, int oflag, int &err) { - CALLFUNCERR(open(filename, oflag)) + int ret; + if(stricmp(filename, "/dev/null") == 0) + ret = open("NUL", oflag); + else + ret = open(filename, oflag); + + if(errno) + err = errno; + return ret; } int CPerlLIO::Open(const char *filename, int oflag, int pmode, int &err) { - CALLFUNCERR(open(filename, oflag, pmode)) + int ret; + if(stricmp(filename, "/dev/null") == 0) + ret = open("NUL", oflag, pmode); + else + ret = open(filename, oflag, pmode); + + if(errno) + err = errno; + return ret; } int CPerlLIO::Read(int fd, void *buffer, unsigned int cnt, int &err) @@ -276,7 +289,44 @@ int CPerlLIO::Setmode(int fd, int mode, int &err) int CPerlLIO::STat(const char *path, struct stat *sbufptr, int &err) { - return stat(path, sbufptr); + char t[MAX_PATH]; + const char *p = path; + int l = strlen(path); + int res; + + if (l > 1) { + switch(path[l - 1]) { + case '\\': + case '/': + if (path[l - 2] != ':') { + strncpy(t, path, l - 1); + t[l - 1] = 0; + p = t; + }; + } + } + res = stat(path, sbufptr); +#ifdef __BORLANDC__ + if (res == 0) { + if (S_ISDIR(buffer->st_mode)) + buffer->st_mode |= S_IWRITE | S_IEXEC; + else if (S_ISREG(buffer->st_mode)) { + if (l >= 4 && path[l-4] == '.') { + const char *e = path + l - 3; + if (strnicmp(e,"exe",3) + && strnicmp(e,"bat",3) + && strnicmp(e,"com",3) + && (IsWin95() || strnicmp(e,"cmd",3))) + buffer->st_mode &= ~S_IEXEC; + else + buffer->st_mode |= S_IEXEC; + } + else + buffer->st_mode &= ~S_IEXEC; + } + } +#endif + return res; } char *CPerlLIO::Tmpnam(char *string, int &err) diff --git a/win32/ipstdio.c b/win32/ipstdio.c index 7d37373b9a..d95c6921a4 100644 --- a/win32/ipstdio.c +++ b/win32/ipstdio.c @@ -16,6 +16,7 @@ public: pPerl = NULL; pSock = NULL; w32_platform = -1; + ZeroMemory(bSocketTable, sizeof(bSocketTable)); }; virtual PerlIO* Stdin(void); virtual PerlIO* Stdout(void); @@ -36,8 +37,11 @@ public: virtual int Ungetc(PerlIO*,int, int &err); virtual int Fileno(PerlIO*, int &err); virtual PerlIO* Fdopen(int, const char *, int &err); + virtual PerlIO* Reopen(const char*, const char*, PerlIO*, int &err); virtual SSize_t Read(PerlIO*,void *,Size_t, int &err); virtual SSize_t Write(PerlIO*,const void *,Size_t, int &err); + virtual void SetBuf(PerlIO *, char*, int &err); + virtual int SetVBuf(PerlIO *, char*, int, Size_t, int &err); virtual void SetCnt(PerlIO *, int, int &err); virtual void SetPtrCnt(PerlIO *, char *, int, int& err); virtual void Setlinebuf(PerlIO*, int &err); @@ -218,7 +222,11 @@ PerlIO* CPerlStdIO::Open(const char *path, const char *mode, int &err) PerlIO* ret = NULL; if(*path != '\0') { - ret = (PerlIO*)fopen(path, mode); + if(stricmp(path, "/dev/null") == 0) + ret = (PerlIO*)fopen("NUL", mode); + else + ret = (PerlIO*)fopen(path, mode); + if(errno) err = errno; } @@ -324,6 +332,14 @@ PerlIO* CPerlStdIO::Fdopen(int fh, const char *mode, int &err) return ret; } +PerlIO* CPerlStdIO::Reopen(const char* filename, const char* mode, PerlIO* pf, int &err) +{ + PerlIO* ret = (PerlIO*)freopen(filename, mode, (FILE*)pf); + if(errno) + err = errno; + return ret; +} + SSize_t CPerlStdIO::Read(PerlIO* pf, void * buffer, Size_t count, int &err) { size_t ret = fread(buffer, 1, count, (FILE*)pf); @@ -340,9 +356,9 @@ SSize_t CPerlStdIO::Write(PerlIO* pf, const void * buffer, Size_t count, int &er return ret; } -void CPerlStdIO::Setlinebuf(PerlIO*, int &err) +void CPerlStdIO::Setlinebuf(PerlIO*pf, int &err) { - croak("setlinebuf not implemented!\n"); + setvbuf((FILE*)pf, NULL, _IOLBF, 0); } int CPerlStdIO::Printf(PerlIO* pf, int &err, const char *format, ...) @@ -425,6 +441,16 @@ char* CPerlStdIO::GetPtr(PerlIO *pf, int &err) return ((FILE*)pf)->_ptr; } +void CPerlStdIO::SetBuf(PerlIO *pf, char* buffer, int &err) +{ + setbuf((FILE*)pf, buffer); +} + +int CPerlStdIO::SetVBuf(PerlIO *pf, char* buffer, int type, Size_t size, int &err) +{ + return setvbuf((FILE*)pf, buffer, type, size); +} + void CPerlStdIO::SetCnt(PerlIO *pf, int n, int &err) { ((FILE*)pf)->_cnt = n; diff --git a/win32/perlobj.def b/win32/perlobj.def index 6b0f65dad8..28816cde11 100644 --- a/win32/perlobj.def +++ b/win32/perlobj.def @@ -1,4 +1,4 @@ -LIBRARY Perl500 +LIBRARY PerlCore DESCRIPTION 'Perl interpreter' EXPORTS perl_alloc diff --git a/win32/runperl.c b/win32/runperl.c index 76f9ea0b93..5cacb83ca5 100644 --- a/win32/runperl.c +++ b/win32/runperl.c @@ -4,7 +4,15 @@ #include "EXTERN.h" #include "perl.h" +#define NO_XSLOCKS #include "XSUB.H" +#undef errno +#if defined(_MT) +_CRTIMP int * __cdecl _errno(void); +#define errno (*_errno()) +#else +_CRTIMP extern int errno; +#endif #include <ipdir.h> #include <ipenv.h> |