diff options
| -rw-r--r-- | global.sym | 1 | ||||
| -rw-r--r-- | miniperlmain.c | 4 | ||||
| -rw-r--r-- | op.c | 10 | ||||
| -rw-r--r-- | perl.c | 7 | ||||
| -rw-r--r-- | perl.h | 4 | ||||
| -rw-r--r-- | perly.c | 2 | ||||
| -rw-r--r-- | perly.c.diff | 53 | ||||
| -rw-r--r-- | perly.y | 2 | ||||
| -rw-r--r-- | pp_ctl.c | 7 | ||||
| -rw-r--r-- | regcomp.c | 7 | ||||
| -rw-r--r-- | regcomp.h | 4 | ||||
| -rw-r--r-- | regexec.c | 16 | ||||
| -rw-r--r-- | sv.c | 4 | ||||
| -rw-r--r-- | sv.h | 72 | ||||
| -rwxr-xr-x | t/op/misc.t | 11 | ||||
| -rwxr-xr-x | t/op/ref.t | 12 | ||||
| -rw-r--r-- | toke.c | 32 | ||||
| -rw-r--r-- | util.c | 5 | ||||
| -rw-r--r-- | vms/perly_c.vms | 11 | ||||
| -rw-r--r-- | win32/Makefile | 14 | ||||
| -rw-r--r-- | win32/config.bc | 11 | ||||
| -rw-r--r-- | win32/config.vc | 5 | ||||
| -rw-r--r-- | win32/config_H.bc | 62 | ||||
| -rw-r--r-- | win32/config_H.vc | 62 | ||||
| -rw-r--r-- | win32/config_h.PL | 15 | ||||
| -rw-r--r-- | win32/config_sh.PL | 11 | ||||
| -rw-r--r-- | win32/makedef.pl | 36 | ||||
| -rw-r--r-- | win32/makefile.mk | 6 | ||||
| -rw-r--r-- | win32/perlglob.c | 4 | ||||
| -rw-r--r-- | win32/perllib.c | 4 | ||||
| -rw-r--r-- | win32/win32.c | 127 | ||||
| -rw-r--r-- | win32/win32.h | 22 | ||||
| -rw-r--r-- | win32/win32iop.h | 7 | ||||
| -rw-r--r-- | win32/win32thread.c | 14 | ||||
| -rw-r--r-- | win32/win32thread.h | 22 |
35 files changed, 534 insertions, 152 deletions
diff --git a/global.sym b/global.sym index 18322a77da..4be609a207 100644 --- a/global.sym +++ b/global.sym @@ -463,7 +463,6 @@ gv_stashpv gv_stashpvn gv_stashsv he_root -hoistmust hv_clear hv_delayfree_ent hv_delete diff --git a/miniperlmain.c b/miniperlmain.c index 27ad541fb4..81e649344d 100644 --- a/miniperlmain.c +++ b/miniperlmain.c @@ -25,6 +25,10 @@ char **env; { int exitstatus; +#ifdef USE_THREADS + MUTEX_INIT(&malloc_mutex); +#endif + PERL_SYS_INIT(&argc,&argv); perl_init_i18nl10n(1); @@ -3438,9 +3438,9 @@ newSUB(I32 floor, OP *o, OP *proto, OP *block) CV *cv; HV *hv; - sv_setpvf(sv, "%_:%ld-%ld", - GvSV(curcop->cop_filegv), - (long)subline, (long)curcop->cop_line); + sv_setpvf(sv, "%_:%ld-%ld", GvSV(curcop->cop_filegv), + (long)(subline < 0 ? -subline : subline), + (long)curcop->cop_line); gv_efullname3(tmpstr, gv, Nullch); hv_store(GvHV(DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0); if (!db_postponed) { @@ -4414,7 +4414,7 @@ ck_shift(OP *o) op_free(o); #ifdef USE_THREADS - if (subline) { + if (subline > 0) { argop = newOP(OP_PADAV, OPf_REF); argop->op_targ = 0; /* curpad[0] is @_ */ } @@ -4425,7 +4425,7 @@ ck_shift(OP *o) } #else argop = newUNOP(OP_RV2AV, 0, - scalar(newGVOP(OP_GV, 0, subline ? + scalar(newGVOP(OP_GV, 0, subline > 0 ? defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV)))); #endif /* USE_THREADS */ return newUNOP(type, 0, scalar(argop)); @@ -1686,6 +1686,9 @@ GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n") break; case '-': case 0: +#ifdef WIN32 + case '\r': +#endif case '\n': case '\t': break; @@ -1987,7 +1990,7 @@ SV *sv; if (strEQ(origfilename,"-")) scriptname = ""; if (fdscript >= 0) { - rsfp = PerlIO_fdopen(fdscript,"r"); + rsfp = PerlIO_fdopen(fdscript,PERL_SCRIPT_MODE); #if defined(HAS_FCNTL) && defined(F_SETFD) if (rsfp) fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */ @@ -2071,7 +2074,7 @@ sed %s -e \"/^[^#]/b\" \ rsfp = PerlIO_stdin(); } else { - rsfp = PerlIO_open(scriptname,"r"); + rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE); #if defined(HAS_FCNTL) && defined(F_SETFD) if (rsfp) fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */ @@ -2297,6 +2297,10 @@ EXT bool numeric_local INIT(TRUE); /* Assume local numerics */ #define printf PerlIO_stdoutf #endif +#ifndef PERL_SCRIPT_MODE +#define PERL_SCRIPT_MODE "r" +#endif + /* * nice_chunk and nice_chunk size need to be set * and queried under the protection of sv_mutex @@ -1767,7 +1767,7 @@ case 56: { char *name = SvPV(((SVOP*)yyvsp[0].opval)->op_sv, na); if (strEQ(name, "BEGIN") || strEQ(name, "END") || strEQ(name, "INIT")) - CvUNIQUE_on(compcv); + { CvUNIQUE_on(compcv); subline = -subline; } yyval.opval = yyvsp[0].opval; } break; case 57: diff --git a/perly.c.diff b/perly.c.diff index b4aec9d598..e13b04bd8c 100644 --- a/perly.c.diff +++ b/perly.c.diff @@ -88,12 +88,24 @@ Index: perly.c - short yyss[YYSTACKSIZE]; - YYSTYPE yyvs[YYSTACKSIZE]; - #define yystacksize YYSTACKSIZE - #line 631 "perly.y" + #line 632 "perly.y" /* PROGRAM */ --- 1283,1288 ---- *************** *** 1361,1372 **** ---- 1291,1347 ---- + #define YYACCEPT goto yyaccept + #define YYERROR goto yyerrlab + int +! yyparse() + { + register int yym, yyn, yystate; + #if YYDEBUG + register char *yys; + extern char *getenv(); + + if (yys = getenv("YYDEBUG")) + { +--- 1291,1348 ---- #define YYACCEPT goto yyaccept #define YYERROR goto yyerrlab + @@ -109,8 +121,7 @@ Index: perly.c + }; + + void -+ yydestruct(ptr) -+ void* ptr; ++ yydestruct(void *ptr) + { + struct ysv* ysave = (struct ysv*)ptr; + if (ysave->yyss) Safefree(ysave->yyss); @@ -125,7 +136,7 @@ Index: perly.c + } + int - yyparse() +! yyparse(void) { register int yym, yyn, yystate; + register short *yyssp; @@ -136,8 +147,10 @@ Index: perly.c + int retval = 0; #if YYDEBUG register char *yys; ++ #ifndef __cplusplus extern char *getenv(); + #endif ++ #endif + + struct ysv *ysave = (struct ysv*)safemalloc(sizeof(struct ysv)); + SAVEDESTRUCTOR(yydestruct, ysave); @@ -153,7 +166,7 @@ Index: perly.c { *************** *** 1381,1384 **** ---- 1356,1367 ---- +--- 1357,1368 ---- yychar = (-1); + /* @@ -173,7 +186,7 @@ Index: perly.c ! printf("yydebug: state %d, reading %d (%s)\n", yystate, yychar, yys); } ---- 1379,1383 ---- +--- 1380,1384 ---- if (yychar <= YYMAXTOKEN) yys = yyname[yychar]; if (!yys) yys = "illegal-symbol"; ! fprintf(stderr, "yydebug: state %d, reading %d (%s)\n", yystate, @@ -191,7 +204,7 @@ Index: perly.c ! goto yyoverflow; } *++yyssp = yystate = yytable[yyn]; ---- 1389,1412 ---- +--- 1390,1413 ---- #if YYDEBUG if (yydebug) ! fprintf(stderr, "yydebug: state %d, shifting to state %d\n", @@ -228,7 +241,7 @@ Index: perly.c ! goto yyoverflow; } *++yyssp = yystate = yytable[yyn]; ---- 1444,1468 ---- +--- 1445,1469 ---- #if YYDEBUG if (yydebug) ! fprintf(stderr, @@ -262,7 +275,7 @@ Index: perly.c ! *yyssp); #endif if (yyssp <= yyss) goto yyabort; ---- 1474,1480 ---- +--- 1475,1481 ---- #if YYDEBUG if (yydebug) ! fprintf(stderr, @@ -278,7 +291,7 @@ Index: perly.c ! yystate, yychar, yys); } #endif ---- 1493,1499 ---- +--- 1494,1500 ---- if (yychar <= YYMAXTOKEN) yys = yyname[yychar]; if (!yys) yys = "illegal-symbol"; ! fprintf(stderr, @@ -293,21 +306,21 @@ Index: perly.c ! printf("yydebug: state %d, reducing by rule %d (%s)\n", yystate, yyn, yyrule[yyn]); #endif ---- 1504,1508 ---- +--- 1505,1509 ---- #if YYDEBUG if (yydebug) ! fprintf(stderr, "yydebug: state %d, reducing by rule %d (%s)\n", yystate, yyn, yyrule[yyn]); #endif *************** -*** 2278,2283 **** +*** 2279,2284 **** #if YYDEBUG if (yydebug) ! printf("yydebug: after reduction, shifting from state 0 to\ ! state %d\n", YYFINAL); #endif yystate = YYFINAL; ---- 2292,2298 ---- +--- 2294,2300 ---- #if YYDEBUG if (yydebug) ! fprintf(stderr, @@ -316,20 +329,20 @@ Index: perly.c #endif yystate = YYFINAL; *************** -*** 2293,2297 **** +*** 2294,2298 **** if (yychar <= YYMAXTOKEN) yys = yyname[yychar]; if (!yys) yys = "illegal-symbol"; ! printf("yydebug: state %d, reading %d (%s)\n", YYFINAL, yychar, yys); } ---- 2308,2312 ---- +--- 2310,2314 ---- if (yychar <= YYMAXTOKEN) yys = yyname[yychar]; if (!yys) yys = "illegal-symbol"; ! fprintf(stderr, "yydebug: state %d, reading %d (%s)\n", YYFINAL, yychar, yys); } *************** -*** 2308,2317 **** +*** 2309,2318 **** #if YYDEBUG if (yydebug) ! printf("yydebug: after reduction, shifting from state %d \ @@ -340,7 +353,7 @@ Index: perly.c ! goto yyoverflow; } *++yyssp = yystate; ---- 2323,2347 ---- +--- 2325,2349 ---- #if YYDEBUG if (yydebug) ! fprintf(stderr, @@ -367,7 +380,7 @@ Index: perly.c } *++yyssp = yystate; *************** -*** 2319,2326 **** +*** 2320,2327 **** goto yyloop; yyoverflow: ! yyerror("yacc stack overflow"); @@ -376,7 +389,7 @@ Index: perly.c yyaccept: ! return (0); } ---- 2349,2356 ---- +--- 2351,2358 ---- goto yyloop; yyoverflow: ! yyerror("Out of memory for yacc stack"); @@ -291,7 +291,7 @@ startformsub: /* NULL */ /* start a format subroutine scope */ subname : WORD { char *name = SvPV(((SVOP*)$1)->op_sv, na); if (strEQ(name, "BEGIN") || strEQ(name, "END") || strEQ(name, "INIT")) - CvUNIQUE_on(compcv); + { CvUNIQUE_on(compcv); subline = -subline; } $$ = $1; } ; @@ -2119,7 +2119,7 @@ sv_compile_2op(SV *sv, OP** startop, char *code, AV** avp) dSP; /* Make POPBLOCK work. */ PERL_CONTEXT *cx; SV **newsp; - I32 gimme; + I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */ I32 optype; OP dummy; OP *oop = op, *rop; @@ -2378,7 +2378,7 @@ PP(pp_require) ) { tryname = name; - tryrsfp = PerlIO_open(name,"r"); + tryrsfp = PerlIO_open(name,PERL_SCRIPT_MODE); } else { AV *ar = GvAVn(incgv); @@ -2401,7 +2401,7 @@ PP(pp_require) sv_setpvf(namesv, "%s/%s", dir, name); #endif tryname = SvPVX(namesv); - tryrsfp = PerlIO_open(tryname, "r"); + tryrsfp = PerlIO_open(tryname, PERL_SCRIPT_MODE); if (tryrsfp) { if (tryname[0] == '.' && tryname[1] == '/') tryname += 2; @@ -2881,3 +2881,4 @@ doparseform(SV *sv) SvCOMPILED_on(sv); } + @@ -372,7 +372,7 @@ study_chunk(regnode **scanp, I32 *deltap, regnode *last, scan_data_t *data, U32 data->last_start_max = is_inf ? I32_MAX : data->pos_min + data->pos_delta; } - sv_catpvn(data->last_found, OPERAND(scan)+1, l); + sv_catpvn(data->last_found, (char *)(OPERAND(scan)+1), l); data->last_end = data->pos_min + l; data->pos_min += l; /* As in the first entry. */ data->flags &= ~SF_BEFORE_EOL; @@ -1673,7 +1673,7 @@ tryagain: ret = reg_node((regflags & PMf_FOLD) ? ((regflags & PMf_LOCALE) ? EXACTFL : EXACTF) : EXACT); - s = OPERAND(ret); + s = (char *) OPERAND(ret); regc(0, s++); /* save spot for len */ for (len = 0, p = regparse - 1; len < 127 && p < regxend; @@ -1841,7 +1841,7 @@ regclass(void) register I32 def; I32 numlen; - s = opnd = OPERAND(regcode); + s = opnd = (char *) OPERAND(regcode); ret = reg_node(ANYOF); for (Class = 0; Class < 33; Class++) regc(0, s++); @@ -2662,3 +2662,4 @@ re_croak2(const char* pat1,const char* pat2, va_alist) croak("%s", buf); } + @@ -144,9 +144,9 @@ typedef OP OP_4tree; /* Will be redefined later. */ */ #ifndef DOINIT -EXT const U8 regkind[]; +EXTCONST U8 regkind[]; #else -EXT const U8 regkind[] = { +EXTCONST U8 regkind[] = { END, BOL, BOL, @@ -411,7 +411,7 @@ regexec_flags(register regexp *prog, char *stringarg, register char *strend, cha goto phooey; } else if (c = prog->regstclass) { I32 doevery = (prog->reganch & ROPT_SKIP) == 0; - char *class; + char *Class; if (minlen) dontbother = minlen - 1; @@ -420,9 +420,9 @@ regexec_flags(register regexp *prog, char *stringarg, register char *strend, cha /* We know what class it must start with. */ switch (OP(c)) { case ANYOF: - class = OPERAND(c); + Class = (char *) OPERAND(c); while (s < strend) { - if (reginclass(class, *s)) { + if (reginclass(Class, *s)) { if (tmp && regtry(prog, s)) goto got_it; else @@ -854,7 +854,7 @@ regmatch(regnode *prog) nextchar = UCHARAT(++locinput); break; case EXACT: - s = OPERAND(scan); + s = (char *) OPERAND(scan); ln = UCHARAT(s++); /* Inline the first character, for speed. */ if (UCHARAT(s) != nextchar) @@ -870,7 +870,7 @@ regmatch(regnode *prog) reg_flags |= RF_tainted; /* FALL THROUGH */ case EXACTF: - s = OPERAND(scan); + s = (char *) OPERAND(scan); ln = UCHARAT(s++); /* Inline the first character, for speed. */ if (UCHARAT(s) != nextchar && @@ -887,7 +887,7 @@ regmatch(regnode *prog) nextchar = UCHARAT(locinput); break; case ANYOF: - s = OPERAND(scan); + s = (char *) OPERAND(scan); if (nextchar < 0) nextchar = UCHARAT(locinput); if (!reginclass(s, nextchar)) @@ -1633,7 +1633,7 @@ regrepeat(regnode *p, I32 max) scan = reginput; if (max != REG_INFTY && max < loceol - scan) loceol = scan + max; - opnd = OPERAND(p); + opnd = (char *) OPERAND(p); switch (OP(p)) { case ANY: while (scan < loceol && *scan != '\n') @@ -1801,3 +1801,5 @@ reginclass(register char *p, register I32 c) return match ^ ((flags & ANYOF_INVERT) != 0); } + + @@ -3219,6 +3219,10 @@ screamer2: } } +#ifdef WIN32 + win32_strip_return(sv); +#endif + return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch; } @@ -492,8 +492,6 @@ struct xpvio { #define SvTAINT(sv) STMT_START{ if(tainted){SvTAINTED_on(sv);} }STMT_END -#ifdef CRIPPLED_CC - #define SvPV_force(sv, lp) sv_pvn_force(sv, &lp) #define SvPV(sv, lp) sv_pvn(sv, &lp) #define SvIVx(sv) sv_iv(sv) @@ -508,7 +506,8 @@ struct xpvio { #define SvUV(sv) SvIVx(sv) #define SvTRUE(sv) SvTRUEx(sv) -#else /* !CRIPPLED_CC */ +#ifndef CRIPPLED_CC +/* redefine some things to more efficient inlined versions */ #undef SvIV #define SvIV(sv) (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) @@ -528,15 +527,26 @@ struct xpvio { ((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK \ ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_pvn_force(sv, &lp)) -#undef SvTRUE -#define SvTRUE(sv) ( \ +#ifdef __GNUC__ +# undef SvIVx +# undef SvUVx +# undef SvNVx +# undef SvPVx +# undef SvTRUE +# undef SvTRUEx +# define SvIVx(sv) ({SV *nsv = (SV*)(sv); SvIV(nsv); }) +# define SvUVx(sv) ({SV *nsv = (SV*)(sv); SvUV(nsv); }) +# define SvNVx(sv) ({SV *nsv = (SV*)(sv); SvNV(nsv); }) +# define SvPVx(sv, lp) ({SV *nsv = (sv); SvPV(nsv, lp); }) +# define SvTRUE(sv) ( \ !sv \ ? 0 \ : SvPOK(sv) \ - ? ((Xpv = (XPV*)SvANY(sv)) && \ - (*Xpv->xpv_pv > '0' || \ - Xpv->xpv_cur > 1 || \ - (Xpv->xpv_cur && *Xpv->xpv_pv != '0')) \ + ? (({XPV *nxpv = (XPV*)SvANY(sv); \ + nxpv && \ + (*nxpv->xpv_pv > '0' || \ + nxpv->xpv_cur > 1 || \ + (nxpv->xpv_cur && *nxpv->xpv_pv != '0')); }) \ ? 1 \ : 0) \ : \ @@ -545,22 +555,42 @@ struct xpvio { : SvNOK(sv) \ ? SvNVX(sv) != 0.0 \ : sv_2bool(sv) ) - -#ifdef __GNUC__ -# define SvIVx(sv) ({SV *nsv = (SV*)(sv); SvIV(nsv); }) -# define SvUVx(sv) ({SV *nsv = (SV*)(sv); SvUV(nsv); }) -# define SvNVx(sv) ({SV *nsv = (SV*)(sv); SvNV(nsv); }) -# define SvPVx(sv, lp) ({SV *nsv = (sv); SvPV(nsv, lp); }) -#else +# define SvTRUEx(sv) ({SV *nsv = (sv); SvTRUE(nsv); }) +#else /* __GNUC__ */ +#ifndef USE_THREADS +/* These inlined macros use globals, which will require a thread + * declaration in user code, so we avoid them under threads */ + +# undef SvIVx +# undef SvUVx +# undef SvNVx +# undef SvPVx +# undef SvTRUE +# undef SvTRUEx # define SvIVx(sv) ((Sv = (sv)), SvIV(Sv)) # define SvUVx(sv) ((Sv = (sv)), SvUV(Sv)) # define SvNVx(sv) ((Sv = (sv)), SvNV(Sv)) # define SvPVx(sv, lp) ((Sv = (sv)), SvPV(Sv, lp)) -#endif /* __GNUC__ */ - -#define SvTRUEx(sv) ((Sv = (sv)), SvTRUE(Sv)) - -#endif /* CRIPPLED_CC */ +# define SvTRUE(sv) ( \ + !sv \ + ? 0 \ + : SvPOK(sv) \ + ? ((Xpv = (XPV*)SvANY(sv)) && \ + (*Xpv->xpv_pv > '0' || \ + Xpv->xpv_cur > 1 || \ + (Xpv->xpv_cur && *Xpv->xpv_pv != '0')) \ + ? 1 \ + : 0) \ + : \ + SvIOK(sv) \ + ? SvIVX(sv) != 0 \ + : SvNOK(sv) \ + ? SvNVX(sv) != 0.0 \ + : sv_2bool(sv) ) +# define SvTRUEx(sv) ((Sv = (sv)), SvTRUE(Sv)) +#endif /* !USE_THREADS */ +#endif /* !__GNU__ */ +#endif /* !CRIPPLED_CC */ #define newRV_inc(sv) newRV(sv) #ifdef __GNUC__ diff --git a/t/op/misc.t b/t/op/misc.t index c529830123..326273aff1 100755 --- a/t/op/misc.t +++ b/t/op/misc.t @@ -345,3 +345,14 @@ EXPECT Unmatched right bracket at (re_eval 1) line 1, at end of line syntax error at (re_eval 1) line 1, near ""{"}" Compilation failed in regexp at - line 1. +######## +BEGIN { @ARGV = qw(a b c) } +BEGIN { print "argv <@ARGV>\nbegin <",shift,">\n" } +END { print "end <",shift,">\nargv <@ARGV>\n" } +INIT { print "init <",shift,">\n" } +EXPECT +argv <a b c> +begin <a> +init <b> +end <c> +argv <> diff --git a/t/op/ref.t b/t/op/ref.t index 9fcc8ac15c..56925177d1 100755 --- a/t/op/ref.t +++ b/t/op/ref.t @@ -1,6 +1,6 @@ #!./perl -print "1..51\n"; +print "1..52\n"; # Test glob operations. @@ -231,12 +231,16 @@ $bar = "ok 48"; local(*bar) = *bar; print "$bar\n"; +$var = "ok 49"; +$_ = \$var; +print $$_,"\n"; + package FINALE; { - $ref3 = bless ["ok 51\n"]; # package destruction - my $ref2 = bless ["ok 50\n"]; # lexical destruction - local $ref1 = bless ["ok 49\n"]; # dynamic destruction + $ref3 = bless ["ok 52\n"]; # package destruction + my $ref2 = bless ["ok 51\n"]; # lexical destruction + local $ref1 = bless ["ok 50\n"]; # dynamic destruction 1; # flush any temp values on stack } @@ -187,7 +187,7 @@ missingterm(char *s) char q; if (s) { char *nl = strrchr(s,'\n'); - if (nl) + if (nl) *nl = '\0'; } else if (multi_close < 32 || multi_close == 127) { @@ -219,6 +219,19 @@ depcom(void) deprecate("comma-less variable list"); } +#ifdef WIN32 + +static I32 +win32_textfilter(int idx, SV *sv, int maxlen) +{ + I32 count = FILTER_READ(idx+1, sv, maxlen); + if (count > 0 && !maxlen) + win32_strip_return(sv); + return count; +} +#endif + + void lex_start(SV *line) { @@ -1158,6 +1171,7 @@ filter_read(int idx, SV *buf_sv, int maxlen) else return 0 ; /* end of file */ } + } return SvCUR(buf_sv); } @@ -1178,9 +1192,15 @@ filter_read(int idx, SV *buf_sv, int maxlen) return (*funcp)(idx, buf_sv, maxlen); } + static char * filter_gets(register SV *sv, register FILE *fp, STRLEN append) { +#ifdef WIN32FILTER + if (!rsfp_filters) { + filter_add(win32_textfilter,NULL); + } +#endif if (rsfp_filters) { if (!append) @@ -1192,7 +1212,6 @@ filter_gets(register SV *sv, register FILE *fp, STRLEN append) } else return (sv_gets(sv, fp, append)); - } @@ -1211,6 +1230,8 @@ yylex(void) register char *d; register I32 tmp; STRLEN len; + GV *gv = Nullgv; + GV **gvp = 0; if (pending_ident) { char pit = pending_ident; @@ -1723,9 +1744,11 @@ yylex(void) } goto retry; case '\r': +#ifndef WIN32CHEAT warn("Illegal character \\%03o (carriage return)", '\r'); croak( "(Maybe you didn't strip carriage returns after a network transfer?)\n"); +#endif case ' ': case '\t': case '\f': case 013: s++; goto retry; @@ -2524,8 +2547,8 @@ yylex(void) case 'z': case 'Z': keylookup: { - GV *gv = Nullgv; - GV **gvp = 0; + gv = Nullgv; + gvp = 0; bufptr = s; s = scan_word(s, tokenbuf, sizeof tokenbuf, FALSE, &len); @@ -5360,3 +5383,4 @@ yyerror(char *s) return 0; } + @@ -867,9 +867,9 @@ fbm_instr(unsigned char *big, register unsigned char *bigend, SV *littlestr) if (!len) { if (SvTAIL(littlestr)) { if (bigend > big && bigend[-1] == '\n') - return bigend - 1; + return (char *)(bigend - 1); else - return bigend; + return (char *) bigend; } return (char*)big; } @@ -2547,3 +2547,4 @@ Perl_huge(void) } #endif + diff --git a/vms/perly_c.vms b/vms/perly_c.vms index 1344fae31e..e3c100b45d 100644 --- a/vms/perly_c.vms +++ b/vms/perly_c.vms @@ -8,7 +8,7 @@ static char yysccsid[] = "@(#)yaccpar 1.8 (Berkeley) 01/20/91"; #include "perl.h" static void -dep() +dep(void) { deprecate("\"do\" to call subroutines"); } @@ -1304,8 +1304,7 @@ struct ysv { }; void -yydestruct(ptr) -void* ptr; +yydestruct(void *ptr) { struct ysv* ysave = (struct ysv*)ptr; if (ysave->yyss) Safefree(ysave->yyss); @@ -1320,7 +1319,7 @@ void* ptr; } int -yyparse() +yyparse(void) { register int yym, yyn, yystate; register short *yyssp; @@ -1331,10 +1330,12 @@ yyparse() int retval = 0; #if YYDEBUG register char *yys; +#ifndef __cplusplus # ifndef getenv extern char *getenv(); # endif #endif +#endif struct ysv *ysave = (struct ysv*)safemalloc(sizeof(struct ysv)); SAVEDESTRUCTOR(yydestruct, ysave); @@ -1769,7 +1770,7 @@ case 56: { char *name = SvPV(((SVOP*)yyvsp[0].opval)->op_sv, na); if (strEQ(name, "BEGIN") || strEQ(name, "END") || strEQ(name, "INIT")) - CvUNIQUE_on(compcv); + { CvUNIQUE_on(compcv); subline = -subline; } yyval.opval = yyvsp[0].opval; } break; case 57: diff --git a/win32/Makefile b/win32/Makefile index d2e464145a..91a417da2f 100644 --- a/win32/Makefile +++ b/win32/Makefile @@ -20,7 +20,7 @@ CORECCOPT= # # uncomment next line if you want debug version of perl (big,slow) -#CFG=Debug +CFG=Debug # # set the install locations of the compiler include/libraries @@ -166,7 +166,8 @@ CORE_C= ..\av.c \ ..\taint.c \ ..\toke.c \ ..\universal.c \ - ..\util.c + ..\util.c \ + ..\malloc.c CORE_OBJ= ..\av.obj \ ..\deb.obj \ @@ -193,7 +194,8 @@ CORE_OBJ= ..\av.obj \ ..\taint.obj \ ..\toke.obj \ ..\universal.obj\ - ..\util.obj + ..\util.obj \ + ..\malloc.obj WIN32_C = perllib.c \ win32.c \ @@ -335,7 +337,7 @@ $(WIN32_OBJ) : $(CORE_H) $(CORE_OBJ) : $(CORE_H) $(DLL_OBJ) : $(CORE_H) -perldll.def : $(MINIPERL) $(CONFIGPM) +perldll.def : $(MINIPERL) $(CONFIGPM) makedef.pl ..\global.sym $(MINIPERL) -w makedef.pl $(DEFINES) $(CCTYPE) > perldll.def $(PERLDLL): perldll.def $(CORE_OBJ) $(WIN32_OBJ) $(DLL_OBJ) @@ -371,10 +373,10 @@ perl95.obj : perl95.c $(CC) $(CFLAGS) -MT -UPERLDLL -c perl95.c win32sckmt.obj : win32sck.c - $(CC) $(CFLAGS) -MT -c $(OBJOUT_FLAG)win32sckmt.obj win32sck.c + $(CC) $(CFLAGS) -MT -UPERLDLL -c $(OBJOUT_FLAG)win32sckmt.obj win32sck.c win32mt.obj : win32.c - $(CC) $(CFLAGS) -MT -c $(OBJOUT_FLAG)win32mt.obj win32.c + $(CC) $(CFLAGS) -MT -UPERLDLL -c $(OBJOUT_FLAG)win32mt.obj win32.c $(PERL95EXE): $(PERLDLL) $(CONFIGPM) $(PERL95_OBJ) $(LINK32) -subsystem:console -out:perl95.exe $(LINK_FLAGS) $(LIBFILES) \ diff --git a/win32/config.bc b/win32/config.bc index e3559a041a..c5340214b8 100644 --- a/win32/config.bc +++ b/win32/config.bc @@ -5,7 +5,7 @@ ## Target system: WIN32 # -archlibexp='~INST_TOP~\lib' +archlibexp='~INST_TOP~\lib\~archname~' archname='MSWin32' cc='bcc32' ccflags='-DWIN32' @@ -13,7 +13,7 @@ cppflags='-DWIN32' dlsrc='dl_win32.xs' dynamic_ext='Socket IO Fcntl Opcode SDBM_File attrs Thread' extensions='~static_ext~ ~dynamic_ext~' -installarchlib='~INST_TOP~\lib' +installarchlib='~INST_TOP~\lib\~archname~' installprivlib='~INST_TOP~\lib' libpth='' libs='' @@ -46,7 +46,7 @@ afs='false' alignbytes='8' aphostname='' ar='tlib /P128' -archlib='~INST_TOP~\lib' +archlib='~INST_TOP~\lib\~archname~' archobjs='' awk='awk' baserev='5.0' @@ -162,7 +162,7 @@ d_msgctl='define' d_msgget='define' d_msgrcv='define' d_msgsnd='define' -d_mymalloc='undef' +d_mymalloc='define' d_nice='undef' d_oldarchlib='undef' d_oldsock='undef' @@ -286,6 +286,9 @@ full_csh='' full_sed='' gcc='' gccversion='' +gethbadd_addr_type='char *' +gethbadd_alen_type='int' +getnbadd_net_type='long' gidtype='gid_t' glibpth='/usr/shlib /lib/pa1.1 /usr/lib/large /lib /usr/lib /usr/lib/386 /lib/386 /lib/large /usr/lib/small /lib/small /usr/ccs/lib /usr/ucblib /usr/shlib ' grep='grep' diff --git a/win32/config.vc b/win32/config.vc index c117689b0b..3e7f9aa523 100644 --- a/win32/config.vc +++ b/win32/config.vc @@ -162,7 +162,7 @@ d_msgctl='define' d_msgget='define' d_msgrcv='define' d_msgsnd='define' -d_mymalloc='undef' +d_mymalloc='define' d_nice='undef' d_oldarchlib='undef' d_oldsock='undef' @@ -286,6 +286,9 @@ full_csh='' full_sed='' gcc='' gccversion='' +gethbadd_addr_type='char *' +gethbadd_alen_type='int' +getnbadd_net_type='long' gidtype='gid_t' glibpth='/usr/shlib /lib/pa1.1 /usr/lib/large /lib /usr/lib /usr/lib/386 /lib/386 /lib/large /usr/lib/small /lib/small /usr/ccs/lib /usr/ucblib /usr/shlib ' grep='grep' diff --git a/win32/config_H.bc b/win32/config_H.bc index 3ba2481a0f..cea8b4e9c3 100644 --- a/win32/config_H.bc +++ b/win32/config_H.bc @@ -10,8 +10,8 @@ * $Id: Config_h.U,v 3.0.1.4 1995/09/25 09:10:49 ram Exp $ */ -/* Configuration time: Thu Apr 11 06:20:49 PDT 1996 - * Configured by: garyng +/* Configuration time: undef + * Configured by: nick * Target system: */ @@ -47,11 +47,7 @@ * where library files may be held under a private library, for * instance. */ -#ifdef _ALPHA_ -#define ARCHNAME "alpha-mswin32" /**/ -#else -#define ARCHNAME "x86-mswin32" /**/ -#endif +#define ARCHNAME "MSWin32-x86-thread" /**/ /* BIN: * This symbol holds the path of the bin directory where the package will @@ -315,6 +311,36 @@ */ /*#define HAS_GETHOSTENT /**/ +/* HAS_GETHBADD: + * This symbol, if defined, indicates that the gethostbyaddr routine is + * available to lookup host names by their IP addresses. + */ +/*#define HAS_GETHBADD /**/ + +/* Gethbadd_addr_t: + * This symbol holds the type used for the 1st argument + * to gethostbyaddr(). + */ +#define Gethbadd_addr_t char * + +/* Gethbadd_alen_t: + * This symbol holds the type used for the 2nd argument + * to gethostbyaddr(). + */ +#define Gethbadd_alen_t int + +/* HAS_GETNBADD: + * This symbol, if defined, indicates that the getnetbyaddr routine is + * available to lookup networks by their IP addresses. + */ +/*#define HAS_GETNBADD /**/ + +/* Gethbadd_net_t: + * This symbol holds the type used for the 1st argument + * to getnetbyaddr(). + */ +#define Getnbadd_net_t long + /* HAS_UNAME: * This symbol, if defined, indicates that the C program may use the * uname() routine to derive the host name. See also HAS_GETHOSTNAME @@ -1103,6 +1129,12 @@ */ /*#define I_NETINET_IN /**/ +/* I_NETDB: + * This symbol, if defined, indicates that <netdb.h> exists and + * should be included. + */ +/*#define I_NETDB /**/ + /* I_PWD: * This symbol, if defined, indicates to the C program that it should * include <pwd.h>. @@ -1434,8 +1466,8 @@ * This symbol contains the ~name expanded version of ARCHLIB, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ -#define ARCHLIB "c:\\perl\\lib" /**/ -#define ARCHLIB_EXP (win32PerlLibPath()) /**/ +#define ARCHLIB "c:\\perl\\lib\\MSWin32-x86-thread" /**/ +#define ARCHLIB_EXP (win32PerlLibPath(ARCHNAME,NULL)) /**/ /* BINCOMPAT3: * This symbol, if defined, indicates that Perl 5.004 should be @@ -1654,7 +1686,7 @@ /* MYMALLOC: * This symbol, if defined, indicates that we're using our own malloc. */ -/*#define MYMALLOC /**/ +#define MYMALLOC /**/ /* OLDARCHLIB: * This variable, if defined, holds the name of the directory in @@ -1682,7 +1714,7 @@ * in programs that are not prepared to deal with ~ expansion at run-time. */ #define PRIVLIB "c:\\perl\\lib" /**/ -#define PRIVLIB_EXP "c:\\perl\\lib" /**/ +#define PRIVLIB_EXP (win32PerlLibPath(NULL)) /**/ /* SH_PATH: * This symbol contains the full pathname to the shell used on this @@ -1691,7 +1723,7 @@ * /bin/pdksh, /bin/ash, /bin/bash, or even something such as * D:/bin/sh.exe. */ -#define SH_PATH "cmd.exe" /**/ +#define SH_PATH "cmd /x /c" /**/ /* SIG_NAME: * This symbol contains a list of signal names in order of @@ -1738,7 +1770,7 @@ * in programs that are not prepared to deal with ~ expansion at run-time. */ #define SITEARCH "c:\\perl\\lib\\site" /**/ -#define SITEARCH_EXP "c:\\perl\\lib\\site" /**/ +#define SITEARCH_EXP (win32PerlLibPath("site",ARCHNAME,NULL)) /**/ /* SITELIB: * This symbol contains the name of the private library for this package. @@ -1754,14 +1786,14 @@ * in programs that are not prepared to deal with ~ expansion at run-time. */ #define SITELIB "c:\\perl\\lib\\site" /**/ -#define SITELIB_EXP "c:\\perl\\lib\\site" /**/ +#define SITELIB_EXP (win32PerlLibPath("site",NULL)) /**/ /* STARTPERL: * This variable contains the string to put in front of a perl * script to make sure (one hopes) that it runs with perl and not * some shell. */ -#define STARTPERL "#perl" /**/ +#define STARTPERL "#!perl" /**/ /* USE_PERLIO: * This symbol, if defined, indicates that the PerlIO abstraction should diff --git a/win32/config_H.vc b/win32/config_H.vc index d2c6d47afb..87ecab8221 100644 --- a/win32/config_H.vc +++ b/win32/config_H.vc @@ -10,8 +10,8 @@ * $Id: Config_h.U,v 3.0.1.4 1995/09/25 09:10:49 ram Exp $ */ -/* Configuration time: Thu Apr 11 06:20:49 PDT 1996 - * Configured by: garyng +/* Configuration time: undef + * Configured by: nick * Target system: */ @@ -47,11 +47,7 @@ * where library files may be held under a private library, for * instance. */ -#ifdef _ALPHA_ -#define ARCHNAME "alpha-mswin32" /**/ -#else -#define ARCHNAME "x86-mswin32" /**/ -#endif +#define ARCHNAME "MSWin32-x86-thread" /**/ /* BIN: * This symbol holds the path of the bin directory where the package will @@ -315,6 +311,36 @@ */ /*#define HAS_GETHOSTENT /**/ +/* HAS_GETHBADD: + * This symbol, if defined, indicates that the gethostbyaddr routine is + * available to lookup host names by their IP addresses. + */ +/*#define HAS_GETHBADD /**/ + +/* Gethbadd_addr_t: + * This symbol holds the type used for the 1st argument + * to gethostbyaddr(). + */ +#define Gethbadd_addr_t char * + +/* Gethbadd_alen_t: + * This symbol holds the type used for the 2nd argument + * to gethostbyaddr(). + */ +#define Gethbadd_alen_t int + +/* HAS_GETNBADD: + * This symbol, if defined, indicates that the getnetbyaddr routine is + * available to lookup networks by their IP addresses. + */ +/*#define HAS_GETNBADD /**/ + +/* Gethbadd_net_t: + * This symbol holds the type used for the 1st argument + * to getnetbyaddr(). + */ +#define Getnbadd_net_t long + /* HAS_UNAME: * This symbol, if defined, indicates that the C program may use the * uname() routine to derive the host name. See also HAS_GETHOSTNAME @@ -1103,6 +1129,12 @@ */ /*#define I_NETINET_IN /**/ +/* I_NETDB: + * This symbol, if defined, indicates that <netdb.h> exists and + * should be included. + */ +/*#define I_NETDB /**/ + /* I_PWD: * This symbol, if defined, indicates to the C program that it should * include <pwd.h>. @@ -1434,8 +1466,8 @@ * This symbol contains the ~name expanded version of ARCHLIB, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ -#define ARCHLIB "c:\\perl\\lib" /**/ -#define ARCHLIB_EXP (win32PerlLibPath()) /**/ +#define ARCHLIB "c:\\perl\\lib\\MSWin32-x86-thread" /**/ +#define ARCHLIB_EXP (win32PerlLibPath(ARCHNAME,NULL)) /**/ /* BINCOMPAT3: * This symbol, if defined, indicates that Perl 5.004 should be @@ -1654,7 +1686,7 @@ /* MYMALLOC: * This symbol, if defined, indicates that we're using our own malloc. */ -/*#define MYMALLOC /**/ +#define MYMALLOC /**/ /* OLDARCHLIB: * This variable, if defined, holds the name of the directory in @@ -1682,7 +1714,7 @@ * in programs that are not prepared to deal with ~ expansion at run-time. */ #define PRIVLIB "c:\\perl\\lib" /**/ -#define PRIVLIB_EXP "c:\\perl\\lib" /**/ +#define PRIVLIB_EXP (win32PerlLibPath(NULL)) /**/ /* SH_PATH: * This symbol contains the full pathname to the shell used on this @@ -1691,7 +1723,7 @@ * /bin/pdksh, /bin/ash, /bin/bash, or even something such as * D:/bin/sh.exe. */ -#define SH_PATH "cmd.exe" /**/ +#define SH_PATH "cmd /x /c" /**/ /* SIG_NAME: * This symbol contains a list of signal names in order of @@ -1738,7 +1770,7 @@ * in programs that are not prepared to deal with ~ expansion at run-time. */ #define SITEARCH "c:\\perl\\lib\\site" /**/ -#define SITEARCH_EXP "c:\\perl\\lib\\site" /**/ +#define SITEARCH_EXP (win32PerlLibPath("site",ARCHNAME,NULL)) /**/ /* SITELIB: * This symbol contains the name of the private library for this package. @@ -1754,14 +1786,14 @@ * in programs that are not prepared to deal with ~ expansion at run-time. */ #define SITELIB "c:\\perl\\lib\\site" /**/ -#define SITELIB_EXP "c:\\perl\\lib\\site" /**/ +#define SITELIB_EXP (win32PerlLibPath("site",NULL)) /**/ /* STARTPERL: * This variable contains the string to put in front of a perl * script to make sure (one hopes) that it runs with perl and not * some shell. */ -#define STARTPERL "#perl" /**/ +#define STARTPERL "#!perl" /**/ /* USE_PERLIO: * This symbol, if defined, indicates that the PerlIO abstraction should diff --git a/win32/config_h.PL b/win32/config_h.PL index 5d47016dc9..679ba99112 100644 --- a/win32/config_h.PL +++ b/win32/config_h.PL @@ -37,8 +37,19 @@ while (<SH>) s#/[ *\*]*\*/#/**/#; if (/^\s*#define\s+ARCHLIB_EXP/) { - $_ = "#define ARCHLIB_EXP (win32PerlLibPath())\t/**/\n" - . "#define APPLLIB_EXP (win32SiteLibPath())\t/**/\n"; + $_ = "#define ARCHLIB_EXP (win32PerlLibPath(ARCHNAME,NULL))\t/**/\n"; + } + if (/^\s*#define\s+PRIVLIB_EXP/) + { + $_ = "#define PRIVLIB_EXP (win32PerlLibPath(NULL))\t/**/\n" + } + if (/^\s*#define\s+SITEARCH_EXP/) + { + $_ = "#define SITEARCH_EXP (win32PerlLibPath(\"site\",ARCHNAME,NULL))\t/**/\n"; + } + if (/^\s*#define\s+SITELIB_EXP/) + { + $_ = "#define SITELIB_EXP (win32PerlLibPath(\"site\",NULL))\t/**/\n"; } print H; } diff --git a/win32/config_sh.PL b/win32/config_sh.PL index 0c3713cb2e..5f3f157a0c 100644 --- a/win32/config_sh.PL +++ b/win32/config_sh.PL @@ -5,6 +5,17 @@ while (@ARGV && $ARGV[0] =~ /^([\w_]+)=(.*)$/) shift(@ARGV); } +$opt{'archname'} = 'MSWin32'; +if (defined $ENV{'PROCESSOR_ARCHITECTURE'}) + { + $opt{'archname'} .= '-'.$ENV{'PROCESSOR_ARCHITECTURE'}; + } + +if ($opt{'ccflags'} =~ /USE_THREADS/) + { + $opt{'archname'} .= '-thread'; + } + if ($] =~ /\.(\d\d\d)?(\d\d)?$/) { # should always be true $opt{PATCHLEVEL} = int($1 || 0); $opt{SUBVERSION} = $2 || '00'; diff --git a/win32/makedef.pl b/win32/makedef.pl index abc89d848a..55b3e29bcd 100644 --- a/win32/makedef.pl +++ b/win32/makedef.pl @@ -20,10 +20,23 @@ while (@ARGV && $ARGV[0] =~ /^-/) $define{$1} = 1 if ($flag =~ /^-D(\w+)$/); } +open(CFG,'config.h') || die "Cannot open config.h:$!"; +while (<CFG>) + { + $define{$1} = 1 if /^\s*#\s*define\s+(MYMALLOC)\b/; + } +close(CFG); + warn join(' ',keys %define)."\n"; my $CCTYPE = shift || "MSVC"; +print "LIBRARY Perl\n"; +print "DESCRIPTION 'Perl interpreter, export autogenerated'\n"; +print "CODE LOADONCALL\n"; +print "DATA LOADONCALL NONSHARED MULTIPLE\n"; +print "EXPORTS\n"; + $skip_sym=<<'!END!OF!SKIP!'; Perl_block_type Perl_additem @@ -143,6 +156,20 @@ Perl_cshname Perl_opsave !END!OF!SKIP! +if ($define{'MYMALLOC'}) + { + $skip_sym .= <<'!END!OF!SKIP!'; +Perl_safefree +Perl_safemalloc +Perl_saferealloc +Perl_safecalloc +!END!OF!SKIP! + emit_symbol('Perl_malloc'); + emit_symbol('Perl_free'); + emit_symbol('Perl_realloc'); + emit_symbol('Perl_calloc'); + } + unless ($define{'USE_THREADS'}) { $skip_sym .= <<'!END!OF!SKIP!'; @@ -193,12 +220,6 @@ unless ($define{'USE_THREADS'}) # sticks in front of them. -print "LIBRARY Perl\n"; -print "DESCRIPTION 'Perl interpreter, export autogenerated'\n"; -print "CODE LOADONCALL\n"; -print "DATA LOADONCALL NONSHARED MULTIPLE\n"; -print "EXPORTS\n"; - open (GLOBAL, "<../global.sym") || die "failed to open global.sym" . $!; while (<GLOBAL>) { my $symbol; @@ -232,6 +253,7 @@ while (<DATA>) { my $symbol; next if (!/^[A-Za-z]/); next if (/^#/); + s/\r//g; $symbol = $_; next if ($skip_sym =~ m/^$symbol/m); $symbol = "Perl_".$symbol if ($define{'USE_THISPTR'} @@ -402,4 +424,6 @@ win32_open_osfhandle win32_get_osfhandle Perl_win32_init Perl_init_os_extras +Perl_getTHR +Perl_setTHR RunPerl diff --git a/win32/makefile.mk b/win32/makefile.mk index 2b7dc8ccbe..03788c731e 100644 --- a/win32/makefile.mk +++ b/win32/makefile.mk @@ -234,7 +234,8 @@ CORE_C= ..\av.c \ ..\taint.c \ ..\toke.c \ ..\universal.c \ - ..\util.c + ..\util.c \ + ..\malloc.c CORE_OBJ= ..\av.obj \ ..\deb.obj \ @@ -261,7 +262,8 @@ CORE_OBJ= ..\av.obj \ ..\taint.obj \ ..\toke.obj \ ..\universal.obj\ - ..\util.obj + ..\util.obj \ + ..\malloc.obj WIN32_C = perllib.c \ win32.c \ diff --git a/win32/perlglob.c b/win32/perlglob.c index b2fdca2f71..be9d55052c 100644 --- a/win32/perlglob.c +++ b/win32/perlglob.c @@ -22,7 +22,8 @@ main(int argc, char *argv[]) /* check out the file system characteristics */ if (GetFullPathName(".", MAX_PATH, root, &dummy)) { - if (dummy = strchr(root, '\\')) + dummy = strchr(root,'\\'); + if (dummy) *++dummy = '\0'; if (GetVolumeInformation(root, volname, MAX_PATH, &serial, &maxname, &flags, 0, 0)) { @@ -40,3 +41,4 @@ main(int argc, char *argv[]) } return 0; } + diff --git a/win32/perllib.c b/win32/perllib.c index 848360698b..c24941f111 100644 --- a/win32/perllib.c +++ b/win32/perllib.c @@ -15,6 +15,10 @@ RunPerl(int argc, char **argv, char **env, void *iosubsystem) int exitstatus; PerlInterpreter *my_perl; +#ifdef USE_THREADS + MUTEX_INIT(&malloc_mutex); +#endif + PERL_SYS_INIT(&argc,&argv); perl_init_i18nl10n(1); diff --git a/win32/win32.c b/win32/win32.c index 4551679f58..74be770ff1 100644 --- a/win32/win32.c +++ b/win32/win32.c @@ -55,30 +55,30 @@ IsWinNT(void) { } char * -win32PerlLibPath(void) +win32PerlLibPath(char *sfx,...) { + va_list ap; char *end; + va_start(ap,sfx); GetModuleFileName((PerlDllHandle == INVALID_HANDLE_VALUE) ? GetModuleHandle(NULL) : PerlDllHandle, szPerlLibRoot, sizeof(szPerlLibRoot)); - *(end = strrchr(szPerlLibRoot, '\\')) = '\0'; if (stricmp(end-4,"\\bin") == 0) end -= 4; strcpy(end,"\\lib"); + while (sfx) + { + strcat(end,"\\"); + strcat(end,sfx); + sfx = va_arg(ap,char *); + } + va_end(ap); return (szPerlLibRoot); } -char * -win32SiteLibPath(void) -{ - static char szPerlSiteLib[MAX_PATH+1]; - strcpy(szPerlSiteLib, win32PerlLibPath()); - strcat(szPerlSiteLib, "\\site"); - return (szPerlSiteLib); -} BOOL HasRedirection(char *ptr) @@ -1303,6 +1303,85 @@ win32_putchar(int c) return putchar(c); } +#ifdef MYMALLOC + +#ifndef USE_PERL_SBRK + +static char *committed = NULL; +static char *base = NULL; +static char *reserved = NULL; +static char *brk = NULL; +static DWORD pagesize = 0; +static DWORD allocsize = 0; + +void * +sbrk(int need) +{ + void *result; + if (!pagesize) + {SYSTEM_INFO info; + GetSystemInfo(&info); + /* Pretend page size is larger so we don't perpetually + * call the OS to commit just one page ... + */ + pagesize = info.dwPageSize << 3; + allocsize = info.dwAllocationGranularity; + } + /* This scheme fails eventually if request for contiguous + * block is denied so reserve big blocks - this is only + * address space not memory ... + */ + if (brk+need >= reserved) + { + DWORD size = 64*1024*1024; + char *addr; + if (committed && reserved && committed < reserved) + { + /* Commit last of previous chunk cannot span allocations */ + addr = (char *) VirtualAlloc(committed,reserved-committed,MEM_COMMIT,PAGE_READWRITE); + if (addr) + committed = reserved; + } + /* Reserve some (more) space + * Note this is a little sneaky, 1st call passes NULL as reserved + * so lets system choose where we start, subsequent calls pass + * the old end address so ask for a contiguous block + */ + addr = (char *) VirtualAlloc(reserved,size,MEM_RESERVE,PAGE_NOACCESS); + if (addr) + { + reserved = addr+size; + if (!base) + base = addr; + if (!committed) + committed = base; + if (!brk) + brk = committed; + } + else + { + return (void *) -1; + } + } + result = brk; + brk += need; + if (brk > committed) + { + DWORD size = ((brk-committed + pagesize -1)/pagesize) * pagesize; + char *addr = (char *) VirtualAlloc(committed,size,MEM_COMMIT,PAGE_READWRITE); + if (addr) + { + committed += size; + } + else + return (void *) -1; + } + return result; +} + +#endif +#endif + DllExport void* win32_malloc(size_t size) { @@ -1327,6 +1406,7 @@ win32_free(void *block) free(block); } + int win32_open_osfhandle(long handle, int flags) { @@ -1645,6 +1725,33 @@ Perl_win32_init(int *argcp, char ***argvp) #endif } +#ifdef USE_BINMODE_SCRIPTS + +void +win32_strip_return(SV *sv) +{ + char *s = SvPVX(sv); + char *e = s+SvCUR(sv); + char *d = s; + while (s < e) + { + if (*s == '\r' && s[1] == '\n') + { + *d++ = '\n'; + s += 2; + } + else + { + *d++ = *s++; + } + } + SvCUR_set(sv,d-SvPVX(sv)); +} + +#endif + + + diff --git a/win32/win32.h b/win32/win32.h index 18bf8a2e96..2e31d0e3ba 100644 --- a/win32/win32.h +++ b/win32/win32.h @@ -111,6 +111,7 @@ extern gid_t getegid(void); extern int setuid(uid_t uid); extern int setgid(gid_t gid); extern int kill(int pid, int sig); +extern void *sbrk(int need); #undef Stat #define Stat win32_stat @@ -128,8 +129,7 @@ extern int my_fclose(FILE *); extern int do_aspawn(void* really, void ** mark, void ** arglast); extern int do_spawn(char *cmd); extern char do_exec(char *cmd); -extern char * win32PerlLibPath(void); -extern char * win32SiteLibPath(void); +extern char * win32PerlLibPath(char *sfx,...); extern int IsWin95(void); extern int IsWinNT(void); @@ -145,4 +145,22 @@ typedef char * caddr_t; /* In malloc.c (core address). */ #include <sys/socket.h> #include <netdb.h> +#ifdef MYMALLOC +#define EMBEDMYMALLOC /**/ +/* #define USE_PERL_SBRK /**/ +/* #define PERL_SBRK_VIA_MALLOC /**/ +#endif + +#ifdef PERLDLL +#define PERL_CORE +#endif + +#ifdef USE_BINMODE_SCRIPTS +#define PERL_SCRIPT_MODE "rb" +EXT void win32_strip_return(struct sv *sv); +#else +#define PERL_SCRIPT_MODE "r" +#define win32_strip_return(sv) NOOP +#endif + #endif /* _INC_WIN32_PERL5 */ diff --git a/win32/win32iop.h b/win32/win32iop.h index a60194d0f0..bd70def18e 100644 --- a/win32/win32iop.h +++ b/win32/win32iop.h @@ -219,10 +219,17 @@ END_EXTERN_C #define puts win32_puts #define getchar win32_getchar #define putchar win32_putchar + +#if !defined(MYMALLOC) || !defined(PERLDLL) +#undef malloc +#undef calloc +#undef realloc +#undef free #define malloc win32_malloc #define calloc win32_calloc #define realloc win32_realloc #define free win32_free +#endif #define pipe(fd) win32_pipe((fd), 512, O_BINARY) #define pause() win32_sleep((32767L << 16) + 32767) diff --git a/win32/win32thread.c b/win32/win32thread.c index 922bef4a5c..3e63327638 100644 --- a/win32/win32thread.c +++ b/win32/win32thread.c @@ -1,6 +1,20 @@ #include "EXTERN.h" #include "perl.h" +__declspec(thread) struct thread *Perl_current_thread = NULL; + +void +Perl_setTHR(struct thread *t) +{ + Perl_current_thread = t; +} + +struct thread * +Perl_getTHR(void) +{ + return Perl_current_thread; +} + void Perl_alloc_thread_key(void) { diff --git a/win32/win32thread.h b/win32/win32thread.h index d2dfe4225c..0d92ffc96f 100644 --- a/win32/win32thread.h +++ b/win32/win32thread.h @@ -105,14 +105,27 @@ typedef HANDLE perl_mutex; typedef THREAD_RET_TYPE thread_func_t(void *); + START_EXTERN_C + +#if defined(PERLDLL) && (!defined(__BORLANDC__) || defined(_DLL)) +extern __declspec(thread) struct thread *Perl_current_thread; +#define SET_THR(t) (Perl_current_thread = t) +#define THR Perl_current_thread +#else +#define THR Perl_getTHR() +#define SET_THR(t) Perl_setTHR(t) +#endif + void Perl_alloc_thread_key _((void)); int Perl_thread_create _((struct perl_thread *thr, thread_func_t *fn)); void Perl_set_thread_self _((struct perl_thread *thr)); +struct perl_thread *Perl_getTHR _((void)); +void Perl_setTHR _((struct perl_thread *t)); END_EXTERN_C #define INIT_THREADS NOOP -#define ALLOC_THREAD_KEY Perl_alloc_thread_key() +#define ALLOC_THREAD_KEY NOOP #define SET_THREAD_SELF(thr) Perl_set_thread_self(thr) #define JOIN(t, avp) \ @@ -122,12 +135,7 @@ END_EXTERN_C croak("panic: JOIN"); \ } STMT_END -#define SET_THR(t) \ - STMT_START { \ - if (TlsSetValue(thr_key, (void *) (t)) == 0) \ - croak("panic: TlsSetValue"); \ - } STMT_END - #define YIELD Sleep(0) #endif /* _WIN32THREAD_H */ + |