From: Jarkko Hietaniemi Date: Tue, 4 Jul 2000 16:28:58 +0000 (+0000) Subject: Win32 patches for cfgperl from Sarathy. X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=ce58e4c2a04da0fdbc16746698a37cdef4d70f56;hp=9bb8fa4d8ccca8c2de391a370dd92749d7f09354;p=p5sagit%2Fp5-mst-13.2.git Win32 patches for cfgperl from Sarathy. p4raw-id: //depot/cfgperl@6307 --- diff --git a/doio.c b/doio.c index 6f62144..d253f98 100644 --- a/doio.c +++ b/doio.c @@ -476,13 +476,13 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw, SV *sv; PerlLIO_dup2(PerlIO_fileno(fp), fd); - MUTEX_LOCK(&PL_fdpid_mutex); + LOCK_FDPID_MUTEX; sv = *av_fetch(PL_fdpid,PerlIO_fileno(fp),TRUE); (void)SvUPGRADE(sv, SVt_IV); pid = SvIVX(sv); SvIVX(sv) = 0; sv = *av_fetch(PL_fdpid,fd,TRUE); - MUTEX_UNLOCK(&PL_fdpid_mutex); + UNLOCK_FDPID_MUTEX; (void)SvUPGRADE(sv, SVt_IV); SvIVX(sv) = pid; if (!was_fdopen) diff --git a/doop.c b/doop.c index 3394db2..0c6e690 100644 --- a/doop.c +++ b/doop.c @@ -23,11 +23,11 @@ #define HALF_UPGRADE(start,end) { \ - U8* new; \ + U8* newstr; \ STRLEN len; \ len = end-start; \ - new = bytes_to_utf8(start, &len); \ - Copy(new,start,len,U8*); \ + newstr = bytes_to_utf8(start, &len); \ + Copy(newstr,start,len,U8*); \ end = start + len; \ } diff --git a/embed.h b/embed.h index 6fc3721..928be19 100644 --- a/embed.h +++ b/embed.h @@ -765,6 +765,9 @@ #endif #define runops_standard Perl_runops_standard #define runops_debug Perl_runops_debug +#if defined(USE_THREADS) +#define sv_lock Perl_sv_lock +#endif #define sv_catpvf_mg Perl_sv_catpvf_mg #define sv_vcatpvf_mg Perl_sv_vcatpvf_mg #define sv_catpv_mg Perl_sv_catpv_mg @@ -1132,7 +1135,6 @@ #define xstat S_xstat # endif #endif -#define lock Perl_lock #if defined(PERL_OBJECT) #endif #define ck_anoncode Perl_ck_anoncode @@ -2215,6 +2217,9 @@ #endif #define runops_standard() Perl_runops_standard(aTHX) #define runops_debug() Perl_runops_debug(aTHX) +#if defined(USE_THREADS) +#define sv_lock(a) Perl_sv_lock(aTHX_ a) +#endif #define sv_vcatpvf_mg(a,b,c) Perl_sv_vcatpvf_mg(aTHX_ a,b,c) #define sv_catpv_mg(a,b) Perl_sv_catpv_mg(aTHX_ a,b) #define sv_catpvn_mg(a,b,c) Perl_sv_catpvn_mg(aTHX_ a,b,c) @@ -2577,7 +2582,6 @@ #define xstat(a) S_xstat(aTHX_ a) # endif #endif -#define lock(a) Perl_lock(aTHX_ a) #if defined(PERL_OBJECT) #endif #define ck_anoncode(a) Perl_ck_anoncode(aTHX_ a) @@ -4337,6 +4341,10 @@ #define runops_standard Perl_runops_standard #define Perl_runops_debug CPerlObj::Perl_runops_debug #define runops_debug Perl_runops_debug +#if defined(USE_THREADS) +#define Perl_sv_lock CPerlObj::Perl_sv_lock +#define sv_lock Perl_sv_lock +#endif #define Perl_sv_catpvf_mg CPerlObj::Perl_sv_catpvf_mg #define sv_catpvf_mg Perl_sv_catpvf_mg #define Perl_sv_vcatpvf_mg CPerlObj::Perl_sv_vcatpvf_mg @@ -5000,8 +5008,6 @@ #define xstat S_xstat # endif #endif -#define Perl_lock CPerlObj::Perl_lock -#define lock Perl_lock #if defined(PERL_OBJECT) #endif #define Perl_ck_anoncode CPerlObj::Perl_ck_anoncode diff --git a/embed.pl b/embed.pl index 7e94a09..3d4f3bb 100755 --- a/embed.pl +++ b/embed.pl @@ -2106,6 +2106,9 @@ Ap |struct perl_vars *|GetVars #endif Ap |int |runops_standard Ap |int |runops_debug +#if defined(USE_THREADS) +Ap |SV* |sv_lock |SV *sv +#endif Afpd |void |sv_catpvf_mg |SV *sv|const char* pat|... Ap |void |sv_vcatpvf_mg |SV* sv|const char* pat|va_list* args Apd |void |sv_catpv_mg |SV *sv|const char *ptr @@ -2515,8 +2518,6 @@ s |void |xstat |int # endif #endif -Arp |SV* |lock |SV *sv - #if defined(PERL_OBJECT) }; #endif diff --git a/global.sym b/global.sym index 9053446..719e50a 100644 --- a/global.sym +++ b/global.sym @@ -480,6 +480,7 @@ Perl_safexfree Perl_GetVars Perl_runops_standard Perl_runops_debug +Perl_sv_lock Perl_sv_catpvf_mg Perl_sv_vcatpvf_mg Perl_sv_catpv_mg @@ -542,4 +543,3 @@ Perl_ptr_table_fetch Perl_ptr_table_store Perl_ptr_table_split Perl_sys_intern_clear -Perl_sys_intern_init diff --git a/gv.c b/gv.c index e24fc45..f18f174 100644 --- a/gv.c +++ b/gv.c @@ -438,14 +438,14 @@ Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method) ENTER; #ifdef USE_THREADS - Perl_lock(aTHX_ (SV *)varstash); + sv_lock((SV *)varstash); #endif if (!isGV(vargv)) gv_init(vargv, varstash, autoload, autolen, FALSE); LEAVE; varsv = GvSV(vargv); #ifdef USE_THREADS - Perl_lock(aTHX_ varsv); + sv_lock(varsv); #endif sv_setpv(varsv, HvNAME(stash)); sv_catpvn(varsv, "::", 2); diff --git a/makedef.pl b/makedef.pl index 108993c..a02a298 100644 --- a/makedef.pl +++ b/makedef.pl @@ -421,7 +421,7 @@ unless ($define{'USE_5005THREADS'}) { Perl_find_threadsv Perl_unlock_condpair Perl_magic_mutexfree - Perl_lock + Perl_sv_lock )]; } diff --git a/objXSUB.h b/objXSUB.h index 4f51cb8..0209fd3 100644 --- a/objXSUB.h +++ b/objXSUB.h @@ -1954,6 +1954,12 @@ #define Perl_runops_debug pPerl->Perl_runops_debug #undef runops_debug #define runops_debug Perl_runops_debug +#if defined(USE_THREADS) +#undef Perl_sv_lock +#define Perl_sv_lock pPerl->Perl_sv_lock +#undef sv_lock +#define sv_lock Perl_sv_lock +#endif #undef Perl_sv_catpvf_mg #define Perl_sv_catpvf_mg pPerl->Perl_sv_catpvf_mg #undef sv_catpvf_mg @@ -2277,10 +2283,6 @@ # if defined(LEAKTEST) # endif #endif -#undef Perl_lock -#define Perl_lock pPerl->Perl_lock -#undef lock -#define lock Perl_lock #if defined(PERL_OBJECT) #endif diff --git a/op.c b/op.c index 97f8d29..1469be9 100644 --- a/op.c +++ b/op.c @@ -6265,8 +6265,8 @@ S_method_2entersub(pTHX_ OP *o, OP *o2, OP *svop) if (o2->op_type == OP_CONST) { STRLEN len; - char *package = SvPV(((SVOP*)o2)->op_sv, len); - stash = gv_stashpvn(package, len, FALSE); + char *pkg = SvPV(((SVOP*)o2)->op_sv, len); + stash = gv_stashpvn(pkg, len, FALSE); } else if (o2->op_type == OP_PADSV) { /* my Dog $spot = shift; $spot->bark */ diff --git a/perlapi.c b/perlapi.c index 26d559a..6a54b94 100755 --- a/perlapi.c +++ b/perlapi.c @@ -3533,6 +3533,15 @@ Perl_runops_debug(pTHXo) { return ((CPerlObj*)pPerl)->Perl_runops_debug(); } +#if defined(USE_THREADS) + +#undef Perl_sv_lock +SV* +Perl_sv_lock(pTHXo_ SV *sv) +{ + return ((CPerlObj*)pPerl)->Perl_sv_lock(sv); +} +#endif #undef Perl_sv_catpvf_mg void @@ -4060,13 +4069,6 @@ Perl_sys_intern_init(pTHXo) # if defined(LEAKTEST) # endif #endif - -#undef Perl_lock -SV* -Perl_lock(pTHXo_ SV *sv) -{ - return ((CPerlObj*)pPerl)->Perl_lock(sv); -} #if defined(PERL_OBJECT) #endif diff --git a/pp.c b/pp.c index efea0c1..1649cf4 100644 --- a/pp.c +++ b/pp.c @@ -5263,7 +5263,7 @@ PP(pp_lock) dTOPss; SV *retsv = sv; #ifdef USE_THREADS - Perl_lock(aTHX_ sv); + sv_lock(sv); #endif /* USE_THREADS */ if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV || SvTYPE(retsv) == SVt_PVCV) { diff --git a/pp_ctl.c b/pp_ctl.c index 9400760..a924d2e 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -892,8 +892,8 @@ PP(pp_sort) PL_sortstash = stash; } #ifdef USE_THREADS - Perl_lock(aTHX_ (SV *)PL_firstgv); - Perl_lock(aTHX_ (SV *)PL_secondgv); + sv_lock((SV *)PL_firstgv); + sv_lock((SV *)PL_secondgv); #endif SAVESPTR(GvSV(PL_firstgv)); SAVESPTR(GvSV(PL_secondgv)); diff --git a/pp_hot.c b/pp_hot.c index 8d35b7e..ea2b932 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -145,7 +145,7 @@ PP(pp_concat) { dPOPTOPssrl; STRLEN len; - U8 *s; + char *s; bool left_utf = DO_UTF8(left); bool right_utf = DO_UTF8(right); @@ -156,7 +156,7 @@ PP(pp_concat) } else { /* Set TARG to PV(left), then add right */ - U8 *l, *c; + char *l, *c; STRLEN targlen; if (TARG == right) /* Need a safe copy elsewhere since we're just about to @@ -182,7 +182,7 @@ PP(pp_concat) /* And now copy, maybe upgrading right to UTF8 on the fly */ for (c = SvEND(TARG); *s; s++) { if (*s & 0x80 && !right_utf) - c = uv_to_utf8(c, *s); + c = (char*)uv_to_utf8((U8*)c, *s); else *c++ = *s; } diff --git a/proto.h b/proto.h index e7a21c3..bd222fe 100644 --- a/proto.h +++ b/proto.h @@ -865,6 +865,9 @@ PERL_CALLCONV struct perl_vars * Perl_GetVars(pTHX); #endif PERL_CALLCONV int Perl_runops_standard(pTHX); PERL_CALLCONV int Perl_runops_debug(pTHX); +#if defined(USE_THREADS) +PERL_CALLCONV SV* Perl_sv_lock(pTHX_ SV *sv); +#endif PERL_CALLCONV void Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...) #ifdef CHECK_FORMAT __attribute__((format(printf,pTHX_2,pTHX_3))) @@ -1267,8 +1270,6 @@ STATIC void S_xstat(pTHX_ int); # endif #endif -PERL_CALLCONV SV* Perl_lock(pTHX_ SV *sv) __attribute__((noreturn)); - #if defined(PERL_OBJECT) }; #endif diff --git a/thread.h b/thread.h index 0ea9e74..8234360 100644 --- a/thread.h +++ b/thread.h @@ -280,7 +280,8 @@ # define UNLOCK_STRTAB_MUTEX MUTEX_UNLOCK(&PL_strtab_mutex) # define LOCK_CRED_MUTEX MUTEX_LOCK(&PL_cred_mutex) # define UNLOCK_CRED_MUTEX MUTEX_UNLOCK(&PL_cred_mutex) - +# define LOCK_FDPID_MUTEX MUTEX_LOCK(&PL_fdpid_mutex) +# define UNLOCK_FDPID_MUTEX MUTEX_UNLOCK(&PL_fdpid_mutex) /* Values and macros for thr->flags */ #define THRf_STATE_MASK 7 @@ -376,6 +377,14 @@ typedef struct condpair { # define UNLOCK_CRED_MUTEX #endif +#ifndef LOCK_FDPID_MUTEX +# define LOCK_FDPID_MUTEX +#endif + +#ifndef UNLOCK_FDPID_MUTEX +# define UNLOCK_FDPID_MUTEX +#endif + /* THR, SET_THR, and dTHR are there for compatibility with old versions */ #ifndef THR # define THR PERL_GET_THX diff --git a/toke.c b/toke.c index d6bb6d9..fc51d91 100644 --- a/toke.c +++ b/toke.c @@ -7391,27 +7391,6 @@ Perl_yyerror(pTHX_ char *s) } -#ifdef PERL_OBJECT -#include "XSUB.h" -#endif - -/* - * restore_rsfp - * Restore a source filter. - */ - -static void -restore_rsfp(pTHXo_ void *f) -{ - PerlIO *fp = (PerlIO*)f; - - if (PL_rsfp == PerlIO_stdin()) - PerlIO_clearerr(PL_rsfp); - else if (PL_rsfp && (PL_rsfp != fp)) - PerlIO_close(PL_rsfp); - PL_rsfp = fp; -} - STATIC char* S_swallow_bom(pTHX_ char *s) { STRLEN slen; @@ -7463,3 +7442,24 @@ S_swallow_bom(pTHX_ char *s) { } return s; } + +#ifdef PERL_OBJECT +#include "XSUB.h" +#endif + +/* + * restore_rsfp + * Restore a source filter. + */ + +static void +restore_rsfp(pTHXo_ void *f) +{ + PerlIO *fp = (PerlIO*)f; + + if (PL_rsfp == PerlIO_stdin()) + PerlIO_clearerr(PL_rsfp); + else if (PL_rsfp && (PL_rsfp != fp)) + PerlIO_close(PL_rsfp); + PL_rsfp = fp; +} diff --git a/util.c b/util.c index e0f1f14..d892e75 100644 --- a/util.c +++ b/util.c @@ -2402,9 +2402,9 @@ Perl_my_popen(pTHX_ char *cmd, char *mode) PerlLIO_close(p[This]); p[This] = p[that]; } - MUTEX_LOCK(&PL_fdpid_mutex); + LOCK_FDPID_MUTEX; sv = *av_fetch(PL_fdpid,p[This],TRUE); - MUTEX_UNLOCK(&PL_fdpid_mutex); + UNLOCK_FDPID_MUTEX; (void)SvUPGRADE(sv,SVt_IV); SvIVX(sv) = pid; PL_forkprocess = pid; @@ -2622,9 +2622,9 @@ Perl_my_pclose(pTHX_ PerlIO *ptr) int saved_win32_errno; #endif - MUTEX_LOCK(&PL_fdpid_mutex); + LOCK_FDPID_MUTEX; svp = av_fetch(PL_fdpid,PerlIO_fileno(ptr),TRUE); - MUTEX_UNLOCK(&PL_fdpid_mutex); + UNLOCK_FDPID_MUTEX; pid = SvIVX(*svp); SvREFCNT_dec(*svp); *svp = &PL_sv_undef; @@ -3497,7 +3497,7 @@ Perl_condpair_magic(pTHX_ SV *sv) } SV * -Perl_lock(pTHX_ SV *osv) +Perl_sv_lock(pTHX_ SV *osv) { MAGIC *mg; SV *sv = osv; @@ -3513,17 +3513,18 @@ Perl_lock(pTHX_ SV *osv) MUTEX_LOCK(MgMUTEXP(mg)); if (MgOWNER(mg) == thr) MUTEX_UNLOCK(MgMUTEXP(mg)); - else { + else { while (MgOWNER(mg)) COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg)); MgOWNER(mg) = thr; - DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": Perl_lock lock 0x%"UVxf"\n", + DEBUG_S(PerlIO_printf(Perl_debug_log, + "0x%"UVxf": Perl_lock lock 0x%"UVxf"\n", PTR2UV(thr), PTR2UV(sv));) MUTEX_UNLOCK(MgMUTEXP(mg)); SAVEDESTRUCTOR_X(Perl_unlock_condpair, sv); } - SvUNLOCK(sv); - return sv; + SvUNLOCK(sv); + return sv; } /* diff --git a/win32/Makefile b/win32/Makefile index d669516..f5ee4c6 100644 --- a/win32/Makefile +++ b/win32/Makefile @@ -972,6 +972,8 @@ utils: $(PERLEXE) $(X2P) copy ..\vms\perlvms.pod .\perlvms.pod copy ..\README.win32 .\perlwin32.pod $(MAKE) -f ..\win32\pod.mak converters + cd ..\lib + $(PERLEXE) lib.pm.PL cd ..\win32 $(PERLEXE) $(PL2BAT) $(UTILS) diff --git a/win32/win32.c b/win32/win32.c index a05a3fe..a4e1a79 100644 --- a/win32/win32.c +++ b/win32/win32.c @@ -2390,9 +2390,9 @@ win32_popen(const char *command, const char *mode) /* close saved handle */ win32_close(oldfd); - MUTEX_LOCK(&PL_fdpid_mutex); + LOCK_FDPID_MUTEX; sv_setiv(*av_fetch(w32_fdpid, p[parent], TRUE), childpid); - MUTEX_UNLOCK(&PL_fdpid_mutex); + UNLOCK_FDPID_MUTEX; /* set process id so that it can be returned by perl's open() */ PL_forkprocess = childpid; @@ -2428,9 +2428,9 @@ win32_pclose(FILE *pf) int childpid, status; SV *sv; - MUTEX_LOCK(&PL_fdpid_mutex); + LOCK_FDPID_MUTEX; sv = *av_fetch(w32_fdpid, win32_fileno(pf), TRUE); - MUTEX_UNLOCK(&PL_fdpid_mutex); + if (SvIOK(sv)) childpid = SvIVX(sv); else @@ -2443,6 +2443,7 @@ win32_pclose(FILE *pf) win32_fclose(pf); SvIVX(sv) = 0; + UNLOCK_FDPID_MUTEX; if (win32_waitpid(childpid, &status, 0) == -1) return -1;