summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--MANIFEST4
-rw-r--r--README.win3215
-rw-r--r--av.c223
-rw-r--r--av.h11
-rw-r--r--deb.c2
-rw-r--r--doio.c86
-rw-r--r--embed.h2
-rw-r--r--ext/DB_File/DB_File.pm6
-rw-r--r--ext/GDBM_File/typemap4
-rw-r--r--ext/NDBM_File/typemap4
-rw-r--r--ext/ODBM_File/typemap4
-rw-r--r--ext/SDBM_File/typemap4
-rw-r--r--global.sym2
-rw-r--r--gv.c6
-rw-r--r--hv.c32
-rwxr-xr-xinstallperl8
-rw-r--r--lib/ExtUtils/MM_Unix.pm29
-rw-r--r--lib/ExtUtils/typemap48
-rw-r--r--lib/File/DosGlob.pm35
-rw-r--r--lib/File/Find.pm4
-rw-r--r--malloc.c4
-rw-r--r--mg.c127
-rw-r--r--op.c38
-rw-r--r--os2/OS2/PrfDB/typemap2
-rw-r--r--perl.c54
-rw-r--r--perl.h11
-rw-r--r--perlsock.h8
-rw-r--r--pod/perlguts.pod185
-rw-r--r--pod/perltie.pod23
-rw-r--r--pod/perlxs.pod7
-rw-r--r--pod/perlxstut.pod10
-rw-r--r--pp.c302
-rw-r--r--pp.h4
-rw-r--r--pp_ctl.c37
-rw-r--r--pp_hot.c59
-rw-r--r--pp_sys.c316
-rw-r--r--proto.h2
-rw-r--r--regcomp.c2
-rw-r--r--scope.c15
-rw-r--r--scope.h8
-rw-r--r--sv.c46
-rw-r--r--sv.h34
-rw-r--r--t/harness1
-rw-r--r--[-rwxr-xr-x]t/lib/thread.t0
-rwxr-xr-xt/op/avhv.t29
-rw-r--r--[-rwxr-xr-x]t/op/nothread.t0
-rwxr-xr-xt/op/push.t3
-rw-r--r--toke.c16
-rw-r--r--universal.c3
-rw-r--r--util.c77
-rw-r--r--win32/Makefile83
-rw-r--r--win32/config.bc7
-rw-r--r--win32/config.gc13
-rw-r--r--win32/config.vc13
-rw-r--r--win32/config_sh.PL11
-rw-r--r--win32/makefile.mk99
-rw-r--r--win32/win32.h18
-rw-r--r--x2p/a2p.h25
-rw-r--r--x2p/a2py.c14
59 files changed, 1373 insertions, 862 deletions
diff --git a/MANIFEST b/MANIFEST
index 2e531294b8..a9094bb942 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -743,7 +743,9 @@ t/lib/soundex.t See if Soundex works
t/lib/symbol.t See if Symbol works
t/lib/texttabs.t See if Text::Tabs works
t/lib/textwrap.t See if Text::Wrap works
-t/lib/timelocal.t See if Time::Local works
+t/lib/tie-push.t Test for Tie::Array
+t/lib/tie-stdarray.t Test for Tie::StdArray
+t/lib/tie-stdpush.t Test for Tie::StdArray
t/lib/thread.t Basic test of threading (skipped if no threads)
t/lib/tie-push.t See if pushing onto tied arrays works
t/lib/tie-stdarray.t See if tied arrays work
diff --git a/README.win32 b/README.win32
index fb42850597..233bb6399c 100644
--- a/README.win32
+++ b/README.win32
@@ -237,16 +237,17 @@ perlglob.bat.
perlglob.exe relies on the argv expansion done by the C Runtime of
the particular compiler you used, and therefore behaves very
differently depending on the Runtime used to build it. To preserve
-compatiblity, perlglob.bat (a perl script/module that can be
-used portably) is installed. Besides being portable, perlglob.bat
-also offers enhanced globbing functionality.
+compatiblity, perlglob.bat (a perl script that can be used portably)
+is installed. Besides being portable, perlglob.bat also offers
+enhanced globbing functionality.
If you want perl to use perlglob.bat instead of perlglob.exe, just
delete perlglob.exe from the install location (or move it somewhere
-perl cannot find). Using File::DosGlob.pm (which is the same
-as perlglob.bat) to override the internal CORE::glob() works about 10
-times faster than spawing perlglob.exe, and you should take this
-approach when writing new modules. See File::DosGlob for details.
+perl cannot find). Using File::DosGlob.pm (which implements the core
+functionality of perlglob.bat) to override the internal CORE::glob()
+works about 10 times faster than spawing perlglob.exe, and you should
+take this approach when writing new modules. See File::DosGlob for
+details.
=item Using perl from the command line
diff --git a/av.c b/av.c
index 176844294e..20c77d8444 100644
--- a/av.c
+++ b/av.c
@@ -21,10 +21,14 @@ av_reify(AV *av)
I32 key;
SV* sv;
- if (AvREAL(av))
- return;
+ if (AvREAL(av))
+ return;
+#ifdef DEBUGGING
+ if (SvRMAGICAL(av) && mg_find((SV*)av,'P'))
+ warn("av_reify called on tied array");
+#endif
key = AvMAX(av) + 1;
- while (key > AvFILL(av) + 1)
+ while (key > AvFILLp(av) + 1)
AvARRAY(av)[--key] = &sv_undef;
while (key) {
sv = AvARRAY(av)[--key];
@@ -44,15 +48,30 @@ void
av_extend(AV *av, I32 key)
{
dTHR; /* only necessary if we have to extend stack */
+ MAGIC *mg;
+ if (SvRMAGICAL(av) && (mg = mg_find((SV*)av,'P'))) {
+ dSP;
+ ENTER;
+ SAVETMPS;
+ PUSHMARK(sp);
+ EXTEND(sp,2);
+ PUSHs(mg->mg_obj);
+ PUSHs(sv_2mortal(newSViv(key+1)));
+ PUTBACK;
+ perl_call_method("EXTEND", G_SCALAR|G_DISCARD);
+ FREETMPS;
+ LEAVE;
+ return;
+ }
if (key > AvMAX(av)) {
SV** ary;
I32 tmp;
I32 newmax;
if (AvALLOC(av) != AvARRAY(av)) {
- ary = AvALLOC(av) + AvFILL(av) + 1;
+ ary = AvALLOC(av) + AvFILLp(av) + 1;
tmp = AvARRAY(av) - AvALLOC(av);
- Move(AvARRAY(av), AvALLOC(av), AvFILL(av)+1, SV*);
+ Move(AvARRAY(av), AvALLOC(av), AvFILLp(av)+1, SV*);
AvMAX(av) += tmp;
SvPVX(av) = (char*)AvALLOC(av);
if (AvREAL(av)) {
@@ -127,6 +146,12 @@ av_fetch(register AV *av, I32 key, I32 lval)
if (!av)
return 0;
+ if (key < 0) {
+ key += AvFILL(av) + 1;
+ if (key < 0)
+ return 0;
+ }
+
if (SvRMAGICAL(av)) {
if (mg_find((SV*)av,'P')) {
dTHR;
@@ -137,12 +162,7 @@ av_fetch(register AV *av, I32 key, I32 lval)
}
}
- if (key < 0) {
- key += AvFILL(av) + 1;
- if (key < 0)
- return 0;
- }
- else if (key > AvFILL(av)) {
+ if (key > AvFILLp(av)) {
if (!lval)
return 0;
if (AvREALISH(av))
@@ -172,42 +192,47 @@ SV**
av_store(register AV *av, I32 key, SV *val)
{
SV** ary;
+ U32 fill;
+
if (!av)
return 0;
if (!val)
val = &sv_undef;
- if (SvRMAGICAL(av)) {
- if (mg_find((SV*)av,'P')) {
- if (val != &sv_undef)
- mg_copy((SV*)av, val, 0, key);
- return 0;
- }
- }
-
if (key < 0) {
key += AvFILL(av) + 1;
if (key < 0)
return 0;
}
+
if (SvREADONLY(av) && key >= AvFILL(av))
croak(no_modify);
+
+ if (SvRMAGICAL(av)) {
+ if (mg_find((SV*)av,'P')) {
+ if (val != &sv_undef) {
+ mg_copy((SV*)av, val, 0, key);
+ }
+ return 0;
+ }
+ }
+
if (!AvREAL(av) && AvREIFY(av))
av_reify(av);
if (key > AvMAX(av))
av_extend(av,key);
ary = AvARRAY(av);
- if (AvFILL(av) < key) {
+ if (AvFILLp(av) < key) {
if (!AvREAL(av)) {
dTHR;
if (av == curstack && key > stack_sp - stack_base)
stack_sp = stack_base + key; /* XPUSH in disguise */
do
- ary[++AvFILL(av)] = &sv_undef;
- while (AvFILL(av) < key);
+ ary[++AvFILLp(av)] = &sv_undef;
+ while (AvFILLp(av) < key);
}
- AvFILL(av) = key;
+ AvFILLp(av) = key;
}
else if (AvREAL(av))
SvREFCNT_dec(ary[key]);
@@ -232,7 +257,7 @@ newAV(void)
AvREAL_on(av);
AvALLOC(av) = 0;
SvPVX(av) = 0;
- AvMAX(av) = AvFILL(av) = -1;
+ AvMAX(av) = AvFILLp(av) = -1;
return av;
}
@@ -250,7 +275,7 @@ av_make(register I32 size, register SV **strp)
New(4,ary,size,SV*);
AvALLOC(av) = ary;
SvPVX(av) = (char*)ary;
- AvFILL(av) = size - 1;
+ AvFILLp(av) = size - 1;
AvMAX(av) = size - 1;
for (i = 0; i < size; i++) {
assert (*strp);
@@ -275,7 +300,7 @@ av_fake(register I32 size, register SV **strp)
Copy(strp,ary,size,SV*);
AvFLAGS(av) = AVf_REIFY;
SvPVX(av) = (char*)ary;
- AvFILL(av) = size - 1;
+ AvFILLp(av) = size - 1;
AvMAX(av) = size - 1;
while (size--) {
assert (*strp);
@@ -296,13 +321,20 @@ av_clear(register AV *av)
warn("Attempt to clear deleted array");
}
#endif
- if (!av || AvMAX(av) < 0)
+ if (!av)
return;
/*SUPPRESS 560*/
+ /* Give any tie a chance to cleanup first */
+ if (SvRMAGICAL(av))
+ mg_clear((SV*)av);
+
+ if (AvMAX(av) < 0)
+ return;
+
if (AvREAL(av)) {
ary = AvARRAY(av);
- key = AvFILL(av) + 1;
+ key = AvFILLp(av) + 1;
while (key) {
SvREFCNT_dec(ary[--key]);
ary[key] = &sv_undef;
@@ -312,10 +344,8 @@ av_clear(register AV *av)
AvMAX(av) += key;
SvPVX(av) = (char*)AvALLOC(av);
}
- AvFILL(av) = -1;
+ AvFILLp(av) = -1;
- if (SvRMAGICAL(av))
- mg_clear((SV*)av);
}
void
@@ -326,15 +356,21 @@ av_undef(register AV *av)
if (!av)
return;
/*SUPPRESS 560*/
+
+ /* Give any tie a chance to cleanup first */
+ if (SvRMAGICAL(av) && mg_find((SV*)av,'P'))
+ av_fill(av, -1); /* mg_clear() ? */
+
if (AvREAL(av)) {
- key = AvFILL(av) + 1;
+ key = AvFILLp(av) + 1;
while (key)
SvREFCNT_dec(AvARRAY(av)[--key]);
}
Safefree(AvALLOC(av));
+ AvARRAY(av) = 0;
AvALLOC(av) = 0;
SvPVX(av) = 0;
- AvMAX(av) = AvFILL(av) = -1;
+ AvMAX(av) = AvFILLp(av) = -1;
if (AvARYLEN(av)) {
SvREFCNT_dec(AvARYLEN(av));
AvARYLEN(av) = 0;
@@ -343,23 +379,54 @@ av_undef(register AV *av)
void
av_push(register AV *av, SV *val)
-{
+{
+ MAGIC *mg;
if (!av)
return;
- av_store(av,AvFILL(av)+1,val);
+ if (SvREADONLY(av))
+ croak(no_modify);
+
+ if (SvRMAGICAL(av) && (mg = mg_find((SV*)av,'P'))) {
+ dSP;
+ PUSHMARK(sp);
+ EXTEND(sp,2);
+ PUSHs(mg->mg_obj);
+ PUSHs(val);
+ PUTBACK;
+ ENTER;
+ perl_call_method("PUSH", G_SCALAR|G_DISCARD);
+ LEAVE;
+ return;
+ }
+ av_store(av,AvFILLp(av)+1,val);
}
SV *
av_pop(register AV *av)
{
SV *retval;
+ MAGIC* mg;
if (!av || AvFILL(av) < 0)
return &sv_undef;
if (SvREADONLY(av))
croak(no_modify);
- retval = AvARRAY(av)[AvFILL(av)];
- AvARRAY(av)[AvFILL(av)--] = &sv_undef;
+ if (SvRMAGICAL(av) && (mg = mg_find((SV*)av,'P'))) {
+ dSP;
+ PUSHMARK(sp);
+ XPUSHs(mg->mg_obj);
+ PUTBACK;
+ ENTER;
+ if (perl_call_method("POP", G_SCALAR)) {
+ retval = newSVsv(*stack_sp--);
+ } else {
+ retval = &sv_undef;
+ }
+ LEAVE;
+ return retval;
+ }
+ retval = AvARRAY(av)[AvFILLp(av)];
+ AvARRAY(av)[AvFILLp(av)--] = &sv_undef;
if (SvSMAGICAL(av))
mg_set((SV*)av);
return retval;
@@ -369,12 +436,29 @@ void
av_unshift(register AV *av, register I32 num)
{
register I32 i;
- register SV **sstr,**dstr;
+ register SV **ary;
+ MAGIC* mg;
if (!av || num <= 0)
return;
if (SvREADONLY(av))
croak(no_modify);
+
+ if (SvRMAGICAL(av) && (mg = mg_find((SV*)av,'P'))) {
+ dSP;
+ PUSHMARK(sp);
+ EXTEND(sp,1+num);
+ PUSHs(mg->mg_obj);
+ while (num-- > 0) {
+ PUSHs(&sv_undef);
+ }
+ PUTBACK;
+ ENTER;
+ perl_call_method("UNSHIFT", G_SCALAR|G_DISCARD);
+ LEAVE;
+ return;
+ }
+
if (!AvREAL(av) && AvREIFY(av))
av_reify(av);
i = AvARRAY(av) - AvALLOC(av);
@@ -384,25 +468,18 @@ av_unshift(register AV *av, register I32 num)
num -= i;
AvMAX(av) += i;
- AvFILL(av) += i;
+ AvFILLp(av) += i;
SvPVX(av) = (char*)(AvARRAY(av) - i);
}
- if (num) {
- av_extend(av,AvFILL(av)+num);
- AvFILL(av) += num;
- dstr = AvARRAY(av) + AvFILL(av);
- sstr = dstr - num;
-#ifdef BUGGY_MSC5
- # pragma loop_opt(off) /* don't loop-optimize the following code */
-#endif /* BUGGY_MSC5 */
- for (i = AvFILL(av) - num; i >= 0; --i) {
- *dstr-- = *sstr--;
-#ifdef BUGGY_MSC5
- # pragma loop_opt() /* loop-optimization back to command-line setting */
-#endif /* BUGGY_MSC5 */
- }
- while (num)
- AvARRAY(av)[--num] = &sv_undef;
+ if (num) {
+ i = AvFILLp(av);
+ av_extend(av, i + num);
+ AvFILLp(av) += num;
+ ary = AvARRAY(av);
+ Move(ary, ary + num, i + 1, SV*);
+ do {
+ ary[--num] = &sv_undef;
+ } while (num);
}
}
@@ -410,17 +487,32 @@ SV *
av_shift(register AV *av)
{
SV *retval;
+ MAGIC* mg;
if (!av || AvFILL(av) < 0)
return &sv_undef;
if (SvREADONLY(av))
croak(no_modify);
+ if (SvRMAGICAL(av) && (mg = mg_find((SV*)av,'P'))) {
+ dSP;
+ PUSHMARK(sp);
+ XPUSHs(mg->mg_obj);
+ PUTBACK;
+ ENTER;
+ if (perl_call_method("SHIFT", G_SCALAR)) {
+ retval = newSVsv(*stack_sp--);
+ } else {
+ retval = &sv_undef;
+ }
+ LEAVE;
+ return retval;
+ }
retval = *AvARRAY(av);
if (AvREAL(av))
*AvARRAY(av) = &sv_undef;
SvPVX(av) = (char*)(AvARRAY(av) + 1);
AvMAX(av)--;
- AvFILL(av)--;
+ AvFILLp(av)--;
if (SvSMAGICAL(av))
mg_set((SV*)av);
return retval;
@@ -435,12 +527,27 @@ av_len(register AV *av)
void
av_fill(register AV *av, I32 fill)
{
+ MAGIC *mg;
if (!av)
croak("panic: null array");
if (fill < 0)
fill = -1;
+ if (SvRMAGICAL(av) && (mg = mg_find((SV*)av,'P'))) {
+ dSP;
+ ENTER;
+ SAVETMPS;
+ PUSHMARK(sp);
+ EXTEND(sp,2);
+ PUSHs(mg->mg_obj);
+ PUSHs(sv_2mortal(newSViv(fill+1)));
+ PUTBACK;
+ perl_call_method("STORESIZE", G_SCALAR|G_DISCARD);
+ FREETMPS;
+ LEAVE;
+ return;
+ }
if (fill <= AvMAX(av)) {
- I32 key = AvFILL(av);
+ I32 key = AvFILLp(av);
SV** ary = AvARRAY(av);
if (AvREAL(av)) {
@@ -454,7 +561,7 @@ av_fill(register AV *av, I32 fill)
ary[++key] = &sv_undef;
}
- AvFILL(av) = fill;
+ AvFILLp(av) = fill;
if (SvSMAGICAL(av))
mg_set((SV*)av);
}
diff --git a/av.h b/av.h
index a8dc60b4cd..8de81f42e4 100644
--- a/av.h
+++ b/av.h
@@ -1,6 +1,6 @@
/* av.h
*
- * Copyright (c) 1991-1997, Larry Wall
+ * Copyright (c) 1991-1998, Larry Wall
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
@@ -9,8 +9,8 @@
struct xpvav {
char* xav_array; /* pointer to first array element */
- SSize_t xav_fill;
- SSize_t xav_max;
+ SSize_t xav_fill; /* Index of last element present */
+ SSize_t xav_max; /* Number of elements for which array has space */
IV xof_off; /* ptr is incremented by offset */
double xnv_nv; /* numeric value, if any */
MAGIC* xmg_magic; /* magic for scalar array */
@@ -30,7 +30,7 @@ struct xpvav {
#define AvARRAY(av) ((SV**)((XPVAV*) SvANY(av))->xav_array)
#define AvALLOC(av) ((XPVAV*) SvANY(av))->xav_alloc
#define AvMAX(av) ((XPVAV*) SvANY(av))->xav_max
-#define AvFILL(av) ((XPVAV*) SvANY(av))->xav_fill
+#define AvFILLp(av) ((XPVAV*) SvANY(av))->xav_fill
#define AvARYLEN(av) ((XPVAV*) SvANY(av))->xav_arylen
#define AvFLAGS(av) ((XPVAV*) SvANY(av))->xav_flags
@@ -45,4 +45,7 @@ struct xpvav {
#define AvREUSED_off(av) (AvFLAGS(av) &= ~AVf_REUSED)
#define AvREALISH(av) (AvFLAGS(av) & (AVf_REAL|AVf_REIFY))
+
+#define AvFILL(av) ((SvRMAGICAL((SV *) (av))) \
+ ? mg_size((SV *) av) : AvFILLp(av))
diff --git a/deb.c b/deb.c
index 95ea3f4087..ea40c00b9a 100644
--- a/deb.c
+++ b/deb.c
@@ -105,7 +105,7 @@ debstackptrs(void)
(long)(stack_max-stack_base));
PerlIO_printf(Perl_debug_log, "%8lx %8lx %8ld %8ld %8ld\n",
(unsigned long)mainstack, (unsigned long)AvARRAY(curstack),
- (long)mainstack, (long)AvFILL(curstack), (long)AvMAX(curstack));
+ (long)mainstack, (long)AvFILLp(curstack), (long)AvMAX(curstack));
return 0;
}
diff --git a/doio.c b/doio.c
index dce271d4af..b25bb9c30f 100644
--- a/doio.c
+++ b/doio.c
@@ -76,7 +76,7 @@
#endif
bool
-do_open(GV *gv, register char *name, I32 len, int as_raw, int rawmode, int rawperm, FILE *supplied_fp)
+do_open(GV *gv, register char *name, I32 len, int as_raw, int rawmode, int rawperm, PerlIO *supplied_fp)
{
register IO *io = GvIOn(gv);
PerlIO *saveifp = Nullfp;
@@ -100,7 +100,7 @@ do_open(GV *gv, register char *name, I32 len, int as_raw, int rawmode, int rawpe
result = 0;
}
else if (IoTYPE(io) == '|')
- result = my_pclose(IoIFP(io));
+ result = PerlProc_pclose(IoIFP(io));
else if (IoIFP(io) != IoOFP(io)) {
if (IoOFP(io)) {
result = PerlIO_close(IoOFP(io));
@@ -121,7 +121,7 @@ do_open(GV *gv, register char *name, I32 len, int as_raw, int rawmode, int rawpe
result = rawmode & 3;
IoTYPE(io) = "<>++"[result];
writing = (result > 0);
- fd = open(name, rawmode, rawperm);
+ fd = PerlLIO_open3(name, rawmode, rawperm);
if (fd == -1)
fp = NULL;
else {
@@ -136,7 +136,7 @@ do_open(GV *gv, register char *name, I32 len, int as_raw, int rawmode, int rawpe
fpmode = (result == 1) ? "w" : "r+";
fp = PerlIO_fdopen(fd, fpmode);
if (!fp)
- close(fd);
+ PerlLIO_close(fd);
}
}
else {
@@ -166,7 +166,7 @@ do_open(GV *gv, register char *name, I32 len, int as_raw, int rawmode, int rawpe
TAINT_PROPER("piped open");
if (dowarn && name[strlen(name)-1] == '|')
warn("Can't do bidirectional pipe");
- fp = my_popen(name,"w");
+ fp = PerlProc_popen(name,"w");
writing = 1;
}
else if (*name == '>') {
@@ -214,10 +214,10 @@ do_open(GV *gv, register char *name, I32 len, int as_raw, int rawmode, int rawpe
fd = -1;
}
if (dodup)
- fd = dup(fd);
+ fd = PerlLIO_dup(fd);
if (!(fp = PerlIO_fdopen(fd,mode))) {
if (dodup)
- close(fd);
+ PerlLIO_close(fd);
}
}
}
@@ -255,7 +255,7 @@ do_open(GV *gv, register char *name, I32 len, int as_raw, int rawmode, int rawpe
if (strNE(name,"-"))
TAINT_ENV();
TAINT_PROPER("piped open");
- fp = my_popen(name,"r");
+ fp = PerlProc_popen(name,"r");
IoTYPE(io) = '|';
}
else {
@@ -278,7 +278,7 @@ do_open(GV *gv, register char *name, I32 len, int as_raw, int rawmode, int rawpe
if (IoTYPE(io) &&
IoTYPE(io) != '|' && IoTYPE(io) != '-') {
dTHR;
- if (Fstat(PerlIO_fileno(fp),&statbuf) < 0) {
+ if (PerlLIO_fstat(PerlIO_fileno(fp),&statbuf) < 0) {
(void)PerlIO_close(fp);
goto say_false;
}
@@ -294,7 +294,7 @@ do_open(GV *gv, register char *name, I32 len, int as_raw, int rawmode, int rawpe
) {
char tmpbuf[256];
Sock_size_t buflen = sizeof tmpbuf;
- if (getsockname(PerlIO_fileno(fp), (struct sockaddr *)tmpbuf,
+ if (PerlSock_getsockname(PerlIO_fileno(fp), (struct sockaddr *)tmpbuf,
&buflen) >= 0
|| errno != ENOTSOCK)
IoTYPE(io) = 's'; /* some OS's return 0 on fstat()ed socket */
@@ -316,7 +316,7 @@ do_open(GV *gv, register char *name, I32 len, int as_raw, int rawmode, int rawpe
int pid;
SV *sv;
- dup2(PerlIO_fileno(fp), fd);
+ PerlLIO_dup2(PerlIO_fileno(fp), fd);
sv = *av_fetch(fdpid,PerlIO_fileno(fp),TRUE);
(void)SvUPGRADE(sv, SVt_IV);
pid = SvIVX(sv);
@@ -375,7 +375,7 @@ nextargv(register GV *gv)
#ifdef HAS_FCHMOD
(void)fchmod(lastfd,filemode);
#else
- (void)chmod(oldname,filemode);
+ (void)PerlLIO_chmod(oldname,filemode);
#endif
}
filemode = 0;
@@ -414,7 +414,7 @@ nextargv(register GV *gv)
sv_catpv(sv,inplace);
#endif
#ifndef FLEXFILENAMES
- if (Stat(SvPVX(sv),&statbuf) >= 0
+ if (PerlLIO_stat(SvPVX(sv),&statbuf) >= 0
&& statbuf.st_dev == filedev
&& statbuf.st_ino == fileino
#ifdef DJGPP
@@ -429,7 +429,7 @@ nextargv(register GV *gv)
#endif
#ifdef HAS_RENAME
#ifndef DOSISH
- if (rename(oldname,SvPVX(sv)) < 0) {
+ if (PerlLIO_rename(oldname,SvPVX(sv)) < 0) {
warn("Can't rename %s to %s: %s, skipping file",
oldname, SvPVX(sv), Strerror(errno) );
do_close(gv,FALSE);
@@ -437,8 +437,8 @@ nextargv(register GV *gv)
}
#else
do_close(gv,FALSE);
- (void)unlink(SvPVX(sv));
- (void)rename(oldname,SvPVX(sv));
+ (void)PerlLIO_unlink(SvPVX(sv));
+ (void)PerlLIO_rename(oldname,SvPVX(sv));
do_open(gv,SvPVX(sv),SvCUR(sv),FALSE,0,0,Nullfp);
#endif /* DOSISH */
#else
@@ -478,13 +478,13 @@ nextargv(register GV *gv)
}
setdefout(argvoutgv);
lastfd = PerlIO_fileno(IoIFP(GvIOp(argvoutgv)));
- (void)Fstat(lastfd,&statbuf);
+ (void)PerlLIO_fstat(lastfd,&statbuf);
#ifdef HAS_FCHMOD
(void)fchmod(lastfd,filemode);
#else
# if !(defined(WIN32) && defined(__BORLANDC__))
/* Borland runtime creates a readonly file! */
- (void)chmod(oldname,filemode);
+ (void)PerlLIO_chmod(oldname,filemode);
# endif
#endif
if (fileuid != statbuf.st_uid || filegid != statbuf.st_gid) {
@@ -531,7 +531,7 @@ do_pipe(SV *sv, GV *rgv, GV *wgv)
if (IoIFP(wstio))
do_close(wgv,FALSE);
- if (pipe(fd) < 0)
+ if (PerlProc_pipe(fd) < 0)
goto badexit;
IoIFP(rstio) = PerlIO_fdopen(fd[0], "r");
IoOFP(wstio) = PerlIO_fdopen(fd[1], "w");
@@ -540,9 +540,9 @@ do_pipe(SV *sv, GV *rgv, GV *wgv)
IoTYPE(wstio) = '>';
if (!IoIFP(rstio) || !IoOFP(wstio)) {
if (IoIFP(rstio)) PerlIO_close(IoIFP(rstio));
- else close(fd[0]);
+ else PerlLIO_close(fd[0]);
if (IoOFP(wstio)) PerlIO_close(IoOFP(wstio));
- else close(fd[1]);
+ else PerlLIO_close(fd[1]);
goto badexit;
}
@@ -598,7 +598,7 @@ io_close(IO *io)
if (IoIFP(io)) {
if (IoTYPE(io) == '|') {
- status = my_pclose(IoIFP(io));
+ status = PerlProc_pclose(IoIFP(io));
STATUS_NATIVE_SET(status);
retval = (STATUS_POSIX == 0);
}
@@ -701,7 +701,7 @@ do_sysseek(GV *gv, long int pos, int whence)
register PerlIO *fp;
if (gv && (io = GvIO(gv)) && (fp = IoIFP(io)))
- return lseek(PerlIO_fileno(fp), pos, whence);
+ return PerlLIO_lseek(PerlIO_fileno(fp), pos, whence);
if (dowarn)
warn("sysseek() on unopened file");
SETERRNO(EBADF,RMS$_IFI);
@@ -719,19 +719,19 @@ Off_t length; /* length to set file to */
struct flock fl;
struct stat filebuf;
- if (Fstat(fd, &filebuf) < 0)
+ if (PerlLIO_fstat(fd, &filebuf) < 0)
return -1;
if (filebuf.st_size < length) {
/* extend file length */
- if ((lseek(fd, (length - 1), 0)) < 0)
+ if ((PerlLIO_lseek(fd, (length - 1), 0)) < 0)
return -1;
/* write a "0" byte */
- if ((write(fd, "", 1)) != 1)
+ if ((PerlLIO_write(fd, "", 1)) != 1)
return -1;
}
else {
@@ -760,7 +760,7 @@ Off_t length; /* length to set file to */
#endif /* F_FREESP */
bool
-do_print(register SV *sv, FILE *fp)
+do_print(register SV *sv, PerlIO *fp)
{
register char *tmps;
STRLEN len;
@@ -819,7 +819,7 @@ my_stat(ARGSproto)
statgv = tmpgv;
sv_setpv(statname,"");
laststype = OP_STAT;
- return (laststatval = Fstat(PerlIO_fileno(IoIFP(io)), &statcache));
+ return (laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &statcache));
}
else {
if (tmpgv == defgv)
@@ -847,7 +847,7 @@ my_stat(ARGSproto)
statgv = Nullgv;
sv_setpv(statname,SvPV(sv, na));
laststype = OP_STAT;
- laststatval = Stat(SvPV(sv, na),&statcache);
+ laststatval = PerlLIO_stat(SvPV(sv, na),&statcache);
if (laststatval < 0 && dowarn && strchr(SvPV(sv, na), '\n'))
warn(warn_nl, "stat");
return laststatval;
@@ -875,9 +875,9 @@ my_lstat(ARGSproto)
PUTBACK;
sv_setpv(statname,SvPV(sv, na));
#ifdef HAS_LSTAT
- laststatval = lstat(SvPV(sv, na),&statcache);
+ laststatval = PerlLIO_lstat(SvPV(sv, na),&statcache);
#else
- laststatval = Stat(SvPV(sv, na),&statcache);
+ laststatval = PerlLIO_stat(SvPV(sv, na),&statcache);
#endif
if (laststatval < 0 && dowarn && strchr(SvPV(sv, na), '\n'))
warn(warn_nl, "lstat");
@@ -904,9 +904,9 @@ do_aexec(SV *really, register SV **mark, register SV **sp)
if (*Argv[0] != '/') /* will execvp use PATH? */
TAINT_ENV(); /* testing IFS here is overkill, probably */
if (really && *(tmps = SvPV(really, na)))
- execvp(tmps,Argv);
+ PerlProc_execvp(tmps,Argv);
else
- execvp(Argv[0],Argv);
+ PerlProc_execvp(Argv[0],Argv);
if (dowarn)
warn("Can't exec \"%s\": %s", Argv[0], Strerror(errno));
}
@@ -960,7 +960,7 @@ do_exec(char *cmd)
*--s = '\0';
if (s[-1] == '\'') {
*--s = '\0';
- execl(cshname,"csh", flags,ncmd,(char*)0);
+ PerlProc_execl(cshname,"csh", flags,ncmd,(char*)0);
*s = '\'';
return FALSE;
}
@@ -987,7 +987,7 @@ do_exec(char *cmd)
break;
}
doshell:
- execl(sh_path, "sh", "-c", cmd, (char*)0);
+ PerlProc_execl(sh_path, "sh", "-c", cmd, (char*)0);
return FALSE;
}
}
@@ -1005,7 +1005,7 @@ do_exec(char *cmd)
}
*a = Nullch;
if (Argv[0]) {
- execvp(Argv[0],Argv);
+ PerlProc_execvp(Argv[0],Argv);
if (errno == ENOEXEC) { /* for system V NIH syndrome */
do_execfree();
goto doshell;
@@ -1045,7 +1045,7 @@ apply(I32 type, register SV **mark, register SV **sp)
tot = sp - mark;
val = SvIVx(*mark);
while (++mark <= sp) {
- if (chmod(SvPVx(*mark, na),val))
+ if (PerlLIO_chmod(SvPVx(*mark, na),val))
tot--;
}
}
@@ -1114,16 +1114,16 @@ apply(I32 type, register SV **mark, register SV **sp)
while (++mark <= sp) {
I32 proc = SvIVx(*mark);
#ifdef HAS_KILLPG
- if (killpg(proc,val)) /* BSD */
+ if (PerlProc_killpg(proc,val)) /* BSD */
#else
- if (kill(-proc,val)) /* SYSV */
+ if (PerlProc_kill(-proc,val)) /* SYSV */
#endif
tot--;
}
}
else {
while (++mark <= sp) {
- if (kill(SvIVx(*mark),val))
+ if (PerlProc_kill(SvIVx(*mark),val))
tot--;
}
}
@@ -1140,9 +1140,9 @@ apply(I32 type, register SV **mark, register SV **sp)
}
else { /* don't let root wipe out directories without -U */
#ifdef HAS_LSTAT
- if (lstat(s,&statbuf) < 0 || S_ISDIR(statbuf.st_mode))
+ if (PerlLIO_lstat(s,&statbuf) < 0 || S_ISDIR(statbuf.st_mode))
#else
- if (Stat(s,&statbuf) < 0 || S_ISDIR(statbuf.st_mode))
+ if (PerlLIO_stat(s,&statbuf) < 0 || S_ISDIR(statbuf.st_mode))
#endif
tot--;
else {
@@ -1175,7 +1175,7 @@ apply(I32 type, register SV **mark, register SV **sp)
#endif
tot = sp - mark;
while (++mark <= sp) {
- if (utime(SvPVx(*mark, na),&utbuf))
+ if (PerlLIO_utime(SvPVx(*mark, na),&utbuf))
tot--;
}
}
diff --git a/embed.h b/embed.h
index 60000eff71..41a6af9e99 100644
--- a/embed.h
+++ b/embed.h
@@ -314,6 +314,7 @@
#define magic_settaint Perl_magic_settaint
#define magic_setuvar Perl_magic_setuvar
#define magic_setvec Perl_magic_setvec
+#define magic_sizepack Perl_magic_sizepack
#define magic_wipepack Perl_magic_wipepack
#define magicname Perl_magicname
#define markstack_grow Perl_markstack_grow
@@ -327,6 +328,7 @@
#define mg_len Perl_mg_len
#define mg_magical Perl_mg_magical
#define mg_set Perl_mg_set
+#define mg_size Perl_mg_size
#define mod Perl_mod
#define mod_amg Perl_mod_amg
#define mod_ass_amg Perl_mod_ass_amg
diff --git a/ext/DB_File/DB_File.pm b/ext/DB_File/DB_File.pm
index d08b21ceab..812464361a 100644
--- a/ext/DB_File/DB_File.pm
+++ b/ext/DB_File/DB_File.pm
@@ -106,7 +106,7 @@ package DB_File::RECNOINFO ;
use strict ;
-@DB_File::RECNOINFO::ISA = qw(DB_File::HASHINFO) ;
+@DB_File::RECNOINFO::ISA = qw(DB_File::HASHINFO) ;
sub TIEHASH
{
@@ -189,7 +189,9 @@ require DynaLoader;
R_SNAPSHOT
__R_UNUSED
-);
+);
+
+*FETCHSIZE = \&length;
sub AUTOLOAD {
my($constname);
diff --git a/ext/GDBM_File/typemap b/ext/GDBM_File/typemap
index a9b73d8b81..73ad370359 100644
--- a/ext/GDBM_File/typemap
+++ b/ext/GDBM_File/typemap
@@ -20,8 +20,8 @@ T_GDATUM
UNIMPLEMENTED
OUTPUT
T_DATUM
- sv_setpvn($arg, $var.dptr, $var.dsize);
+ SvSetMagicPVN($arg, $var.dptr, $var.dsize);
T_GDATUM
- sv_usepvn($arg, $var.dptr, $var.dsize);
+ SvUseMagicPVN($arg, $var.dptr, $var.dsize);
T_PTROBJ
sv_setref_pv($arg, dbtype, (void*)$var);
diff --git a/ext/NDBM_File/typemap b/ext/NDBM_File/typemap
index a9b73d8b81..73ad370359 100644
--- a/ext/NDBM_File/typemap
+++ b/ext/NDBM_File/typemap
@@ -20,8 +20,8 @@ T_GDATUM
UNIMPLEMENTED
OUTPUT
T_DATUM
- sv_setpvn($arg, $var.dptr, $var.dsize);
+ SvSetMagicPVN($arg, $var.dptr, $var.dsize);
T_GDATUM
- sv_usepvn($arg, $var.dptr, $var.dsize);
+ SvUseMagicPVN($arg, $var.dptr, $var.dsize);
T_PTROBJ
sv_setref_pv($arg, dbtype, (void*)$var);
diff --git a/ext/ODBM_File/typemap b/ext/ODBM_File/typemap
index a6b0e5faa8..c2c3e3e725 100644
--- a/ext/ODBM_File/typemap
+++ b/ext/ODBM_File/typemap
@@ -20,6 +20,6 @@ T_GDATUM
UNIMPLEMENTED
OUTPUT
T_DATUM
- sv_setpvn($arg, $var.dptr, $var.dsize);
+ SvSetMagicPVN($arg, $var.dptr, $var.dsize);
T_GDATUM
- sv_usepvn($arg, $var.dptr, $var.dsize);
+ SvUseMagicPVN($arg, $var.dptr, $var.dsize);
diff --git a/ext/SDBM_File/typemap b/ext/SDBM_File/typemap
index a9b73d8b81..73ad370359 100644
--- a/ext/SDBM_File/typemap
+++ b/ext/SDBM_File/typemap
@@ -20,8 +20,8 @@ T_GDATUM
UNIMPLEMENTED
OUTPUT
T_DATUM
- sv_setpvn($arg, $var.dptr, $var.dsize);
+ SvSetMagicPVN($arg, $var.dptr, $var.dsize);
T_GDATUM
- sv_usepvn($arg, $var.dptr, $var.dsize);
+ SvUseMagicPVN($arg, $var.dptr, $var.dsize);
T_PTROBJ
sv_setref_pv($arg, dbtype, (void*)$var);
diff --git a/global.sym b/global.sym
index 969f752ab6..979f8d1818 100644
--- a/global.sym
+++ b/global.sym
@@ -416,6 +416,7 @@ magic_settaint
magic_setuvar
magic_setvec
magic_set_all_env
+magic_sizepack
magic_wipepack
magicname
markstack_grow
@@ -429,6 +430,7 @@ mg_get
mg_len
mg_magical
mg_set
+mg_size
mod
modkids
moreswitches
diff --git a/gv.c b/gv.c
index 7d8df6cd17..251e453733 100644
--- a/gv.c
+++ b/gv.c
@@ -183,7 +183,8 @@ gv_fetchmeth(HV *stash, char *name, STRLEN len, I32 level)
if (av) {
SV** svp = AvARRAY(av);
- I32 items = AvFILL(av) + 1;
+ /* NOTE: No support for tied ISA */
+ I32 items = AvFILLp(av) + 1;
while (items--) {
SV* sv = *svp++;
HV* basestash = gv_stashsv(sv, FALSE);
@@ -582,7 +583,8 @@ gv_fetchpv(char *nambeg, I32 add, I32 sv_type)
AV* av = GvAVn(gv);
GvMULTI_on(gv);
sv_magic((SV*)av, (SV*)gv, 'I', Nullch, 0);
- if (add & 2 && strEQ(nambeg,"AnyDBM_File::ISA") && AvFILL(av) == -1)
+ /* NOTE: No support for tied ISA */
+ if (add & 2 && strEQ(nambeg,"AnyDBM_File::ISA") && AvFILLp(av) == -1)
{
char *pname;
av_push(av, newSVpv(pname = "NDBM_File",0));
diff --git a/hv.c b/hv.c
index d973ea8268..25f14220fb 100644
--- a/hv.c
+++ b/hv.c
@@ -423,6 +423,7 @@ hv_delete(HV *hv, char *key, U32 klen, I32 flags)
register U32 hash;
register HE *entry;
register HE **oentry;
+ SV **svp;
SV *sv;
if (!hv)
@@ -432,8 +433,8 @@ hv_delete(HV *hv, char *key, U32 klen, I32 flags)
bool needs_store;
hv_magic_check (hv, &needs_copy, &needs_store);
- if (needs_copy) {
- sv = *hv_fetch(hv, key, klen, TRUE);
+ if (needs_copy && (svp = hv_fetch(hv, key, klen, TRUE))) {
+ sv = *svp;
mg_clear(sv);
if (!needs_store) {
if (mg_find(sv, 'p')) {
@@ -442,13 +443,13 @@ hv_delete(HV *hv, char *key, U32 klen, I32 flags)
}
return Nullsv; /* element cannot be deleted */
}
- }
#ifdef ENV_IS_CASELESS
- else if (mg_find((SV*)hv,'E')) {
- sv = sv_2mortal(newSVpv(key,klen));
- key = strupr(SvPVX(sv));
- }
+ else if (mg_find((SV*)hv,'E')) {
+ sv = sv_2mortal(newSVpv(key,klen));
+ key = strupr(SvPVX(sv));
+ }
#endif
+ }
}
xhv = (XPVHV*)SvANY(hv);
if (!xhv->xhv_array)
@@ -501,8 +502,7 @@ hv_delete_ent(HV *hv, SV *keysv, I32 flags, U32 hash)
bool needs_store;
hv_magic_check (hv, &needs_copy, &needs_store);
- if (needs_copy) {
- entry = hv_fetch_ent(hv, keysv, TRUE, hash);
+ if (needs_copy && (entry = hv_fetch_ent(hv, keysv, TRUE, hash))) {
sv = HeVAL(entry);
mg_clear(sv);
if (!needs_store) {
@@ -512,15 +512,15 @@ hv_delete_ent(HV *hv, SV *keysv, I32 flags, U32 hash)
}
return Nullsv; /* element cannot be deleted */
}
- }
#ifdef ENV_IS_CASELESS
- else if (mg_find((SV*)hv,'E')) {
- key = SvPV(keysv, klen);
- keysv = sv_2mortal(newSVpv(key,klen));
- (void)strupr(SvPVX(keysv));
- hash = 0;
- }
+ else if (mg_find((SV*)hv,'E')) {
+ key = SvPV(keysv, klen);
+ keysv = sv_2mortal(newSVpv(key,klen));
+ (void)strupr(SvPVX(keysv));
+ hash = 0;
+ }
#endif
+ }
}
xhv = (XPVHV*)SvANY(hv);
if (!xhv->xhv_array)
diff --git a/installperl b/installperl
index ee00cd16a5..150b334f8c 100755
--- a/installperl
+++ b/installperl
@@ -2,6 +2,7 @@
BEGIN {
require 5.004;
+ chdir '..' if !-d 'lib' and -d '..\lib';
@INC = 'lib';
$ENV{PERL5LIB} = 'lib';
}
@@ -87,8 +88,9 @@ if ($d_dosuid && $>) { die "You must run as root to install suidperl\n"; }
-x 'perl' . $exe_ext || die "perl isn't executable!\n";
-x 'suidperl' . $exe_ext|| die "suidperl isn't executable!\n" if $d_dosuid;
--x 't/TEST' || warn "WARNING: You've never run 'make test'!!!",
- " (Installing anyway.)\n";
+-x 't/TEST' || $^O eq 'MSWin32'
+ || warn "WARNING: You've never run 'make test'!!!",
+ " (Installing anyway.)\n";
if ($^O eq 'MSWin32') {
@@ -160,7 +162,7 @@ foreach $file (@corefiles) {
$mainperl_is_instperl = 0;
-if (!$versiononly && !$nonono && -t STDIN && -t STDERR
+if (!$versiononly && !$nonono && $^O ne 'MSWin32' && -t STDIN && -t STDERR
&& -w $mainperldir && ! samepath($mainperldir, $installbin)) {
local($usrbinperl) = "$mainperldir/perl$exe_ext";
local($instperl) = "$installbin/perl$exe_ext";
diff --git a/lib/ExtUtils/MM_Unix.pm b/lib/ExtUtils/MM_Unix.pm
index 6703245562..888e5396dc 100644
--- a/lib/ExtUtils/MM_Unix.pm
+++ b/lib/ExtUtils/MM_Unix.pm
@@ -1155,6 +1155,7 @@ sub fixin { # stolen from the pink Camel book, more or less
my($shb) = "";
if ($interpreter) {
print STDOUT "Changing sharpbang in $file to $interpreter" if $Verbose;
+ # this is probably value-free on DOSISH platforms
if ($does_shbang) {
$shb .= "$Config{'sharpbang'}$interpreter";
$shb .= ' ' . $arg if defined $arg;
@@ -1163,18 +1164,14 @@ sub fixin { # stolen from the pink Camel book, more or less
$shb .= qq{
eval 'exec $interpreter $arg -S \$0 \${1+"\$\@"}'
if 0; # not running under some shell
-};
+} unless $Is_Win32; # this won't work on win32, so don't
} else {
warn "Can't find $cmd in PATH, $file unchanged"
if $Verbose;
next;
}
- unless ( rename($file, "$file.bak") ) {
- warn "Can't modify $file";
- next;
- }
- unless ( open(FIXOUT,">$file") ) {
+ unless ( open(FIXOUT,">$file.new") ) {
warn "Can't create new $file: $!\n";
next;
}
@@ -1188,6 +1185,19 @@ eval 'exec $interpreter $arg -S \$0 \${1+"\$\@"}'
print FIXOUT $shb, <FIXIN>;
close FIXIN;
close FIXOUT;
+ # can't rename open files on some DOSISH platforms
+ unless ( rename($file, "$file.bak") ) {
+ warn "Can't rename $file to $file.bak: $!";
+ next;
+ }
+ unless ( rename("$file.new", $file) ) {
+ warn "Can't rename $file.new to $file: $!";
+ unless ( rename("$file.bak", $file) ) {
+ warn "Can't rename $file.bak back to $file either: $!";
+ warn "Leaving $file renamed as $file.bak\n";
+ }
+ next;
+ }
unlink "$file.bak";
} continue {
chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
@@ -1997,9 +2007,12 @@ sub installbin {
push(@m, qq{
EXE_FILES = @{$self->{EXE_FILES}}
-FIXIN = \$(PERL) -I\$(PERL_ARCHLIB) -I\$(PERL_LIB) -MExtUtils::MakeMaker \\
+} . ($Is_Win32
+ ? q{FIXIN = $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) \
+ -e "system qq[pl2bat.bat ].shift"
+} : q{FIXIN = $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::MakeMaker \
-e "MY->fixin(shift)"
-
+}).qq{
all :: @to
$self->{NOECHO}\$(NOOP)
diff --git a/lib/ExtUtils/typemap b/lib/ExtUtils/typemap
index 20cc96f0b5..430c28ad3d 100644
--- a/lib/ExtUtils/typemap
+++ b/lib/ExtUtils/typemap
@@ -190,44 +190,44 @@ T_HVREF
T_CVREF
$arg = newRV((SV*)$var);
T_IV
- sv_setiv($arg, (IV)$var);
+ SvSetMagicIV($arg, (IV)$var);
T_INT
- sv_setiv($arg, (IV)$var);
+ SvSetMagicIV($arg, (IV)$var);
T_SYSRET
if ($var != -1) {
if ($var == 0)
- sv_setpvn($arg, "0 but true", 10);
+ SvSetMagicPVN($arg, "0 but true", 10);
else
- sv_setiv($arg, (IV)$var);
+ SvSetMagicIV($arg, (IV)$var);
}
T_ENUM
- sv_setiv($arg, (IV)$var);
+ SvSetMagicIV($arg, (IV)$var);
T_BOOL
$arg = boolSV($var);
T_U_INT
- sv_setiv($arg, (IV)$var);
+ SvSetMagicIV($arg, (IV)$var);
T_SHORT
- sv_setiv($arg, (IV)$var);
+ SvSetMagicIV($arg, (IV)$var);
T_U_SHORT
- sv_setiv($arg, (IV)$var);
+ SvSetMagicIV($arg, (IV)$var);
T_LONG
- sv_setiv($arg, (IV)$var);
+ SvSetMagicIV($arg, (IV)$var);
T_U_LONG
- sv_setiv($arg, (IV)$var);
+ SvSetMagicIV($arg, (IV)$var);
T_CHAR
- sv_setpvn($arg, (char *)&$var, 1);
+ SvSetMagicPVN($arg, (char *)&$var, 1);
T_U_CHAR
- sv_setiv($arg, (IV)$var);
+ SvSetMagicIV($arg, (IV)$var);
T_FLOAT
- sv_setnv($arg, (double)$var);
+ SvSetMagicNV($arg, (double)$var);
T_NV
- sv_setnv($arg, (double)$var);
+ SvSetMagicNV($arg, (double)$var);
T_DOUBLE
- sv_setnv($arg, (double)$var);
+ SvSetMagicNV($arg, (double)$var);
T_PV
- sv_setpv((SV*)$arg, $var);
+ SvSetMagicPV((SV*)$arg, $var);
T_PTR
- sv_setiv($arg, (IV)$var);
+ SvSetMagicIV($arg, (IV)$var);
T_PTRREF
sv_setref_pv($arg, Nullch, (void*)$var);
T_REF_IV_REF
@@ -244,17 +244,17 @@ T_REFREF
T_REFOBJ
NOT IMPLEMENTED
T_OPAQUE
- sv_setpvn($arg, (char *)&$var, sizeof($var));
+ SvSetMagicPVN($arg, (char *)&$var, sizeof($var));
T_OPAQUEPTR
- sv_setpvn($arg, (char *)$var, sizeof(*$var)), XFree((char *)$var);
+ SvSetMagicPVN($arg, (char *)$var, sizeof(*$var)), XFree((char *)$var);
T_PACKED
XS_pack_$ntype($arg, $var);
T_PACKEDARRAY
XS_pack_$ntype($arg, $var, count_$ntype);
T_DATAUNIT
- sv_setpvn($arg, $var.chp(), $var.size());
+ SvSetMagicPVN($arg, $var.chp(), $var.size());
T_CALLBACK
- sv_setpvn($arg, $var.context.value().chp(),
+ SvSetMagicPVN($arg, $var.context.value().chp(),
$var.context.value().size());
T_ARRAY
ST_EXTEND($var.size);
@@ -267,7 +267,7 @@ T_IN
{
GV *gv = newGVgen("$Package");
if ( do_open(gv, "<&", 2, FALSE, 0, 0, $var) )
- sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1)));
+ SvSetMagicSV($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1)));
else
$arg = &sv_undef;
}
@@ -275,7 +275,7 @@ T_INOUT
{
GV *gv = newGVgen("$Package");
if ( do_open(gv, "+<&", 3, FALSE, 0, 0, $var) )
- sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1)));
+ SvSetMagicSV($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1)));
else
$arg = &sv_undef;
}
@@ -283,7 +283,7 @@ T_OUT
{
GV *gv = newGVgen("$Package");
if ( do_open(gv, "+>&", 3, FALSE, 0, 0, $var) )
- sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1)));
+ SvSetMagicSV($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1)));
else
$arg = &sv_undef;
}
diff --git a/lib/File/DosGlob.pm b/lib/File/DosGlob.pm
index 4597c71564..a27dad9030 100644
--- a/lib/File/DosGlob.pm
+++ b/lib/File/DosGlob.pm
@@ -6,21 +6,6 @@
package File::DosGlob;
-unless (caller) {
- $| = 1;
- while (@ARGV) {
- #
- # We have to do this one by one for compatibility reasons.
- # If an arg doesn't match anything, we are supposed to return
- # the original arg. I know, it stinks, eh?
- #
- my $arg = shift;
- my @m = doglob(1,$arg);
- print (@m ? join("\0", sort @m) : $arg);
- print "\0" if @ARGV;
- }
-}
-
sub doglob {
my $cond = shift;
my @retval = ();
@@ -159,8 +144,6 @@ __END__
File::DosGlob - DOS like globbing and then some
-perlglob.bat - a more capable perlglob.exe replacement
-
=head1 SYNOPSIS
require 5.004;
@@ -173,14 +156,11 @@ perlglob.bat - a more capable perlglob.exe replacement
# from the command line (overrides only in main::)
> perl -MFile::DosGlob=glob -e "print <../pe*/*p?>"
-
- > perlglob ../pe*/*p?
=head1 DESCRIPTION
A module that implements DOS-like globbing with a few enhancements.
-This file is also a portable replacement for perlglob.exe. It
-is largely compatible with perlglob.exe (the M$ setargv.obj
+It is largely compatible with perlglob.exe (the M$ setargv.obj
version) in all but one respect--it understands wildcards in
directory components.
@@ -191,17 +171,6 @@ backslashes and forward slashes are both accepted, and preserved.
You may have to double the backslashes if you are putting them in
literally, due to double-quotish parsing of the pattern by perl.
-When invoked as a program, it will print null-separated filenames
-to standard output.
-
-While one may replace perlglob.exe with this, usage by overriding
-CORE::glob via importation should be much more efficient, because
-it avoids launching a separate process, and is therefore strongly
-recommended. Note that it is currently possible to override
-builtins like glob() only on a per-package basis, not "globally".
-Thus, every namespace that wants to override glob() must explicitly
-request the override. See L<perlsub>.
-
Extending it to csh patterns is left as an exercise to the reader.
=head1 EXPORTS (by request only)
@@ -246,5 +215,7 @@ Initial version (GSAR 20-FEB-97)
perl
+perlglob.bat
+
=cut
diff --git a/lib/File/Find.pm b/lib/File/Find.pm
index 70629d4ce0..11835067ff 100644
--- a/lib/File/Find.pm
+++ b/lib/File/Find.pm
@@ -95,7 +95,6 @@ sub find {
my $fixtopdir = $topdir;
$fixtopdir =~ s,/$,, ;
$fixtopdir =~ s/\.dir$// if $Is_VMS;
- $fixtopdir =~ s/\\dir$// if $Is_NT;
&finddir($wanted,$fixtopdir,$topnlink);
}
}
@@ -156,7 +155,6 @@ sub finddir {
if (!$prune && chdir $_) {
$name =~ s/\.dir$// if $Is_VMS;
- $name =~ s/\\dir$// if $Is_NT;
&finddir($wanted,$name,$nlink);
chdir '..';
}
@@ -185,7 +183,6 @@ sub finddepth {
my $fixtopdir = $topdir;
$fixtopdir =~ s,/$,, ;
$fixtopdir =~ s/\.dir$// if $Is_VMS;
- $fixtopdir =~ s/\\dir$// if $Is_NT;
&finddepthdir($wanted,$fixtopdir,$topnlink);
($dir,$_) = ($fixtopdir,'.');
$name = $fixtopdir;
@@ -245,7 +242,6 @@ sub finddepthdir {
if (chdir $_) {
$name =~ s/\.dir$// if $Is_VMS;
- $name =~ s/\\dir$// if $Is_NT;
&finddepthdir($wanted,$name,$nlink);
chdir '..';
}
diff --git a/malloc.c b/malloc.c
index e52c09f3e2..6b2275c8dd 100644
--- a/malloc.c
+++ b/malloc.c
@@ -265,7 +265,7 @@ static void
botch(char *s)
{
PerlIO_printf(PerlIO_stderr(), "assertion botched: %s\n", s);
- abort();
+ PerlProc_abort();
}
#else
#define ASSERT(p)
@@ -508,7 +508,7 @@ free(void *mp)
if (OV_MAGIC(ovp, bucket) != MAGIC) {
static int bad_free_warn = -1;
if (bad_free_warn == -1) {
- char *pbf = getenv("PERL_BADFREE");
+ char *pbf = PerlEnv_getenv("PERL_BADFREE");
bad_free_warn = (pbf) ? atoi(pbf) : 1;
}
if (!bad_free_warn)
diff --git a/mg.c b/mg.c
index 1d0014315d..af2dddc87e 100644
--- a/mg.c
+++ b/mg.c
@@ -170,6 +170,37 @@ mg_len(SV *sv)
return len;
}
+I32
+mg_size(SV *sv)
+{
+ MAGIC* mg;
+ I32 len;
+
+ for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
+ MGVTBL* vtbl = mg->mg_virtual;
+ if (vtbl && vtbl->svt_len) {
+ MGS mgs;
+ ENTER;
+ /* omit MGf_GSKIP -- not changed here */
+ len = (*vtbl->svt_len)(sv, mg);
+ LEAVE;
+ return len;
+ }
+ }
+
+ switch(SvTYPE(sv)) {
+ case SVt_PVAV:
+ len = AvFILLp((AV *) sv); /* Fallback to non-tied array */
+ return len;
+ case SVt_PVHV:
+ /* FIXME */
+ default:
+ croak("Size magic not implemented");
+ break;
+ }
+ return 0;
+}
+
int
mg_clear(SV *sv)
{
@@ -865,8 +896,9 @@ magic_setisa(SV *sv, MAGIC *mg)
stash = GvSTASH(mg->mg_obj);
svp = AvARRAY((AV*)sv);
-
- for (fill = AvFILL((AV*)sv); fill >= 0; fill--, svp++) {
+
+ /* NOTE: No support for tied ISA */
+ for (fill = AvFILLp((AV*)sv); fill >= 0; fill--, svp++) {
HV *basestash = gv_stashsv(*svp, FALSE);
if (!basestash) {
@@ -920,30 +952,46 @@ magic_setnkeys(SV *sv, MAGIC *mg)
LvTARG(sv) = Nullsv; /* Don't allow a ref to reassign this. */
}
return 0;
-}
+}
static int
-magic_methpack(SV *sv, MAGIC *mg, char *meth)
+magic_methcall(MAGIC *mg, char *meth, I32 flags, int n, SV *val)
{
dSP;
- ENTER;
- SAVETMPS;
PUSHMARK(sp);
- EXTEND(sp, 2);
+ EXTEND(sp, n);
PUSHs(mg->mg_obj);
- if (mg->mg_ptr) {
- 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);
+ if (n > 1) {
+ if (mg->mg_ptr) {
+ 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_len)));
+ }
+ }
+ if (n > 2) {
+ PUSHs(val);
}
- else if (mg->mg_type == 'p')
- PUSHs(sv_2mortal(newSViv(mg->mg_len)));
PUTBACK;
- if (perl_call_method(meth, G_SCALAR))
+ return perl_call_method(meth, flags);
+}
+
+static int
+magic_methpack(SV *sv, MAGIC *mg, char *meth)
+{
+ dSP;
+
+ ENTER;
+ SAVETMPS;
+
+ if (magic_methcall(mg, meth, G_SCALAR, 2, NULL)) {
sv_setsv(sv, *stack_sp--);
+ }
FREETMPS;
LEAVE;
@@ -961,25 +1009,10 @@ magic_getpack(SV *sv, MAGIC *mg)
int
magic_setpack(SV *sv, MAGIC *mg)
-{
- dSP;
-
- PUSHMARK(sp);
- EXTEND(sp, 3);
- PUSHs(mg->mg_obj);
- if (mg->mg_ptr) {
- 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_len)));
- PUSHs(sv);
- PUTBACK;
-
- perl_call_method("STORE", G_SCALAR|G_DISCARD);
-
+{
+ ENTER;
+ magic_methcall(mg, "STORE", G_SCALAR|G_DISCARD, 3, sv);
+ LEAVE;
return 0;
}
@@ -989,6 +1022,24 @@ magic_clearpack(SV *sv, MAGIC *mg)
return magic_methpack(sv,mg,"DELETE");
}
+
+U32
+magic_sizepack(SV *sv, MAGIC *mg)
+{
+ dTHR;
+ U32 retval = 0;
+
+ ENTER;
+ SAVETMPS;
+ if (magic_methcall(mg, "FETCHSIZE", G_SCALAR, 2, NULL)) {
+ sv = *stack_sp--;
+ retval = (U32) SvIV(sv)-1;
+ }
+ FREETMPS;
+ LEAVE;
+ return retval;
+}
+
int magic_wipepack(SV *sv, MAGIC *mg)
{
dSP;
@@ -996,9 +1047,9 @@ int magic_wipepack(SV *sv, MAGIC *mg)
PUSHMARK(sp);
XPUSHs(mg->mg_obj);
PUTBACK;
-
+ ENTER;
perl_call_method("CLEAR", G_SCALAR|G_DISCARD);
-
+ LEAVE;
return 0;
}
@@ -1208,7 +1259,7 @@ magic_getdefelem(SV *sv, MAGIC *mg)
targ = HeVAL(he);
}
else {
- AV* av = (AV*)LvTARG(sv);
+ AV* av = (AV*)LvTARG(sv);
if ((I32)LvTARGOFF(sv) <= AvFILL(av))
targ = AvARRAY(av)[LvTARGOFF(sv)];
}
@@ -1812,7 +1863,7 @@ sighandler(int sig)
oldstack = curstack;
if (curstack != signalstack)
- AvFILL(signalstack) = 0;
+ AvFILLp(signalstack) = 0;
SWITCHSTACK(curstack, signalstack);
if(psig_name[sig]) {
diff --git a/op.c b/op.c
index af0445cac8..88d647518b 100644
--- a/op.c
+++ b/op.c
@@ -108,9 +108,9 @@ pad_allocmy(char *name)
}
croak("Can't use global %s in \"my\"",name);
}
- if (dowarn && AvFILL(comppad_name) >= 0) {
+ if (dowarn && AvFILLp(comppad_name) >= 0) {
SV **svp = AvARRAY(comppad_name);
- for (off = AvFILL(comppad_name); off > comppad_name_floor; off--) {
+ for (off = AvFILLp(comppad_name); off > comppad_name_floor; off--) {
if ((sv = svp[off])
&& sv != &sv_undef
&& SvIVX(sv) == 999999999 /* var is in open scope */
@@ -176,7 +176,7 @@ pad_findlex(char *name, PADOFFSET newoff, U32 seq, CV* startcv, I32 cx_ix)
continue;
curname = (AV*)*svp;
svp = AvARRAY(curname);
- for (off = AvFILL(curname); off > 0; off--) {
+ for (off = AvFILLp(curname); off > 0; off--) {
if ((sv = svp[off]) &&
sv != &sv_undef &&
seq <= SvIVX(sv) &&
@@ -307,7 +307,7 @@ pad_findmy(char *name)
#endif /* USE_THREADS */
/* The one we're looking for is probably just before comppad_name_fill. */
- for (off = AvFILL(comppad_name); off > 0; off--) {
+ for (off = AvFILLp(comppad_name); off > 0; off--) {
if ((sv = svp[off]) &&
sv != &sv_undef &&
(!SvIVX(sv) ||
@@ -345,7 +345,7 @@ pad_leavemy(I32 fill)
}
}
/* "Deintroduce" my variables that are leaving with this scope. */
- for (off = AvFILL(comppad_name); off > fill; off--) {
+ for (off = AvFILLp(comppad_name); off > fill; off--) {
if ((sv = svp[off]) && sv != &sv_undef && SvIVX(sv) == 999999999)
SvIVX(sv) = cop_seqmax;
}
@@ -364,13 +364,13 @@ pad_alloc(I32 optype, U32 tmptype)
pad_reset();
if (tmptype & SVs_PADMY) {
do {
- sv = *av_fetch(comppad, AvFILL(comppad) + 1, TRUE);
+ sv = *av_fetch(comppad, AvFILLp(comppad) + 1, TRUE);
} while (SvPADBUSY(sv)); /* need a fresh one */
- retval = AvFILL(comppad);
+ retval = AvFILLp(comppad);
}
else {
SV **names = AvARRAY(comppad_name);
- SSize_t names_fill = AvFILL(comppad_name);
+ SSize_t names_fill = AvFILLp(comppad_name);
for (;;) {
/*
* "foreach" index vars temporarily become aliases to non-"my"
@@ -1503,7 +1503,7 @@ block_start(int full)
int retval = savestack_ix;
SAVEI32(comppad_name_floor);
if (full) {
- if ((comppad_name_fill = AvFILL(comppad_name)) > 0)
+ if ((comppad_name_fill = AvFILLp(comppad_name)) > 0)
comppad_name_floor = comppad_name_fill;
else
comppad_name_floor = 0;
@@ -3027,7 +3027,7 @@ cv_undef(CV *cv)
if (CvPADLIST(cv)) {
/* may be during global destruction */
if (SvREFCNT(CvPADLIST(cv))) {
- I32 i = AvFILL(CvPADLIST(cv));
+ I32 i = AvFILLp(CvPADLIST(cv));
while (i >= 0) {
SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE);
SV* sv = svp ? *svp : Nullsv;
@@ -3081,7 +3081,7 @@ CV* cv;
pname = AvARRAY(pad_name);
ppad = AvARRAY(pad);
- for (ix = 1; ix <= AvFILL(pad_name); ix++) {
+ for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
if (SvPOK(pname[ix]))
PerlIO_printf(Perl_debug_log, "\t%4d. 0x%lx (%s\"%s\" %ld-%ld)\n",
ix, ppad[ix],
@@ -3104,8 +3104,8 @@ cv_clone2(CV *proto, CV *outside)
AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
SV** pname = AvARRAY(protopad_name);
SV** ppad = AvARRAY(protopad);
- I32 fname = AvFILL(protopad_name);
- I32 fpad = AvFILL(protopad);
+ I32 fname = AvFILLp(protopad_name);
+ I32 fpad = AvFILLp(protopad);
AV* comppadlist;
CV* cv;
@@ -3150,7 +3150,7 @@ cv_clone2(CV *proto, CV *outside)
av_store(comppadlist, 0, (SV*)comppad_name);
av_store(comppadlist, 1, (SV*)comppad);
CvPADLIST(cv) = comppadlist;
- av_fill(comppad, AvFILL(protopad));
+ av_fill(comppad, AvFILLp(protopad));
curpad = AvARRAY(comppad);
av = newAV(); /* will be @_ */
@@ -3387,12 +3387,12 @@ newSUB(I32 floor, OP *o, OP *proto, OP *block)
return cv;
}
- if (AvFILL(comppad_name) < AvFILL(comppad))
- av_store(comppad_name, AvFILL(comppad), Nullsv);
+ if (AvFILLp(comppad_name) < AvFILLp(comppad))
+ av_store(comppad_name, AvFILLp(comppad), Nullsv);
if (CvCLONE(cv)) {
SV **namep = AvARRAY(comppad_name);
- for (ix = AvFILL(comppad); ix > 0; ix--) {
+ for (ix = AvFILLp(comppad); ix > 0; ix--) {
SV *namesv;
if (SvIMMORTAL(curpad[ix]))
@@ -3418,7 +3418,7 @@ newSUB(I32 floor, OP *o, OP *proto, OP *block)
av_store(comppad, 0, (SV*)av);
AvFLAGS(av) = AVf_REIFY;
- for (ix = AvFILL(comppad); ix > 0; ix--) {
+ for (ix = AvFILLp(comppad); ix > 0; ix--) {
if (SvIMMORTAL(curpad[ix]))
continue;
if (!SvPADMY(curpad[ix]))
@@ -3607,7 +3607,7 @@ newFORM(I32 floor, OP *o, OP *block)
CvGV(cv) = (GV*)SvREFCNT_inc(gv);
CvFILEGV(cv) = curcop->cop_filegv;
- for (ix = AvFILL(comppad); ix > 0; ix--) {
+ for (ix = AvFILLp(comppad); ix > 0; ix--) {
if (!SvPADMY(curpad[ix]) && !SvIMMORTAL(curpad[ix]))
SvPADTMP_on(curpad[ix]);
}
diff --git a/os2/OS2/PrfDB/typemap b/os2/OS2/PrfDB/typemap
index 0b91f3750a..1e01470f87 100644
--- a/os2/OS2/PrfDB/typemap
+++ b/os2/OS2/PrfDB/typemap
@@ -11,4 +11,4 @@ T_PVNULL
#############################################################################
OUTPUT
T_PVNULL
- sv_setpv((SV*)$arg, $var);
+ SvSetMagicPV((SV*)$arg, $var);
diff --git a/perl.c b/perl.c
index f18c3b0b53..54fb772d4e 100644
--- a/perl.c
+++ b/perl.c
@@ -88,7 +88,7 @@ static int fdscript = -1;
static void
catch_sigsegv(int signo, struct sigcontext_struct sc)
{
- signal(SIGSEGV, SIG_DFL);
+ PerlProc_signal(SIGSEGV, SIG_DFL);
fprintf(stderr, "Segmentation fault dereferencing 0x%lx\n"
"return_address = 0x%lx, eip = 0x%lx\n",
sc.cr2, __builtin_return_address(0), sc.eip);
@@ -311,7 +311,7 @@ perl_destruct(register PerlInterpreter *sv_interp)
#ifdef DEBUGGING
{
char *s;
- if (s = getenv("PERL_DESTRUCT_LEVEL")) {
+ if (s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL")) {
int i = atoi(s);
if (destruct_level < i)
destruct_level = i;
@@ -689,7 +689,7 @@ setuid perl scripts securely.\n");
croak("No -e allowed in setuid scripts");
if (!e_fp) {
e_tmpname = savepv(TMPPATH);
- (void)mktemp(e_tmpname);
+ (void)PerlLIO_mktemp(e_tmpname);
if (!*e_tmpname)
croak("Can't mktemp()");
e_fp = PerlIO_open(e_tmpname,"w");
@@ -821,7 +821,7 @@ print \" \\@INC:\\n @INC\\n\";");
}
switch_end:
- if (!tainting && (s = getenv("PERL5OPT"))) {
+ if (!tainting && (s = PerlEnv_getenv("PERL5OPT"))) {
while (s && *s) {
while (isSPACE(*s))
s++;
@@ -853,7 +853,7 @@ print \" \\@INC:\\n @INC\\n\";");
}
else if (scriptname == Nullch) {
#ifdef MSDOS
- if ( isatty(PerlIO_fileno(PerlIO_stdin())) )
+ if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
moreswitches("h");
#endif
scriptname = "-";
@@ -902,7 +902,7 @@ print \" \\@INC:\\n @INC\\n\";");
#endif
#if defined(DEBUGGING) && defined(USE_THREADS) && defined(__linux__)
- DEBUG_L(signal(SIGSEGV, (void(*)(int))catch_sigsegv););
+ DEBUG_L(PerlProc_signal(SIGSEGV, (void(*)(int))catch_sigsegv););
#endif
init_predump_symbols();
@@ -950,7 +950,7 @@ print \" \\@INC:\\n @INC\\n\";");
FREETMPS;
#ifdef MYMALLOC
- if ((s=getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
+ if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
dump_mstats("after compilation:");
#endif
@@ -987,7 +987,7 @@ perl_run(PerlInterpreter *sv_interp)
if (endav)
call_list(oldscope, endav);
#ifdef MYMALLOC
- if (getenv("PERL_DEBUG_MSTATS"))
+ if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
dump_mstats("after execution: ");
#endif
JMPENV_POP;
@@ -1532,7 +1532,7 @@ moreswitches(char *s)
return s;
case 'h':
usage(origargv[0]);
- exit(0);
+ PerlProc_exit(0);
case 'i':
if (inplace)
Safefree(inplace);
@@ -1674,7 +1674,7 @@ moreswitches(char *s)
printf("\n\
Perl may be copied only under the terms of either the Artistic License or the\n\
GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n");
- exit(0);
+ PerlProc_exit(0);
case 'w':
dowarn = TRUE;
s++;
@@ -1728,7 +1728,7 @@ my_unexec(void)
if (status)
PerlIO_printf(PerlIO_stderr(), "unexec of %s into %s failed!\n",
SvPVX(prog), SvPVX(file));
- exit(status);
+ PerlProc_exit(status);
#else
# ifdef VMS
# include <lib$routines.h>
@@ -1903,7 +1903,7 @@ SV *sv;
#ifdef DOSISH
&& !strchr(scriptname, '\\')
#endif
- && (s = getenv("PATH"))) {
+ && (s = PerlEnv_getenv("PATH"))) {
bool seen_dot = 0;
bufend = s + strlen(s);
@@ -2074,7 +2074,7 @@ sed %s -e \"/^[^#]/b\" \
croak("Can't do seteuid!\n");
}
#endif /* IAMSUID */
- rsfp = my_popen(SvPVX(cmd), "r");
+ rsfp = PerlProc_popen(SvPVX(cmd), "r");
SvREFCNT_dec(cmd);
SvREFCNT_dec(cpp);
}
@@ -2098,7 +2098,7 @@ sed %s -e \"/^[^#]/b\" \
if (euid && Stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
statbuf.st_mode & (S_ISUID|S_ISGID)) {
/* try again */
- execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
+ PerlProc_execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
croak("Can't do setuid\n");
}
#endif
@@ -2137,7 +2137,7 @@ validate_suid(char *validarg, char *scriptname)
dTHR;
char *s, *s2;
- if (Fstat(PerlIO_fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
+ if (PerlLIO_fstat(PerlIO_fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
croak("Can't stat script \"%s\"",origfilename);
if (fdscript < 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) {
I32 len;
@@ -2152,7 +2152,7 @@ validate_suid(char *validarg, char *scriptname)
* But I don't think it's too important. The manual lies when
* it says access() is useful in setuid programs.
*/
- if (access(SvPVX(GvSV(curcop->cop_filegv)),1)) /*double check*/
+ if (PerlLIO_access(SvPVX(GvSV(curcop->cop_filegv)),1)) /*double check*/
croak("Permission denied");
#else
/* If we can swap euid and uid, then we can determine access rights
@@ -2178,7 +2178,7 @@ validate_suid(char *validarg, char *scriptname)
if (tmpstatbuf.st_dev != statbuf.st_dev ||
tmpstatbuf.st_ino != statbuf.st_ino) {
(void)PerlIO_close(rsfp);
- if (rsfp = my_popen("/bin/mail root","w")) { /* heh, heh */
+ if (rsfp = PerlProc_popen("/bin/mail root","w")) { /* heh, heh */
PerlIO_printf(rsfp,
"User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
(Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
@@ -2186,7 +2186,7 @@ validate_suid(char *validarg, char *scriptname)
(long)statbuf.st_dev, (long)statbuf.st_ino,
SvPVX(GvSV(curcop->cop_filegv)),
(long)statbuf.st_uid, (long)statbuf.st_gid);
- (void)my_pclose(rsfp);
+ (void)PerlProc_pclose(rsfp);
}
croak("Permission denied\n");
}
@@ -2245,7 +2245,7 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
(void)PerlIO_close(rsfp);
#ifndef IAMSUID
/* try again */
- execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
+ PerlProc_execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
#endif
croak("Can't do setuid\n");
}
@@ -2318,7 +2318,7 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
/* exec the real perl, substituting fd script for scriptname. */
/* (We pass script name as "subdir" of fd, which perl will grok.) */
PerlIO_rewind(rsfp);
- lseek(PerlIO_fileno(rsfp),(Off_t)0,0); /* just in case rewind didn't */
+ PerlLIO_lseek(PerlIO_fileno(rsfp),(Off_t)0,0); /* just in case rewind didn't */
for (which = 1; origargv[which] && origargv[which] != scriptname; which++) ;
if (!origargv[which])
croak("Permission denied");
@@ -2327,14 +2327,14 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
#if defined(HAS_FCNTL) && defined(F_SETFD)
fcntl(PerlIO_fileno(rsfp),F_SETFD,0); /* ensure no close-on-exec */
#endif
- execv(form("%s/perl%s", BIN_EXP, patchlevel), origargv); /* try again */
+ PerlProc_execv(form("%s/perl%s", BIN_EXP, patchlevel), origargv); /* try again */
croak("Can't do setuid\n");
#endif /* IAMSUID */
#else /* !DOSUID */
if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */
#ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
dTHR;
- Fstat(PerlIO_fileno(rsfp),&statbuf); /* may be either wrapped or real suid */
+ PerlLIO_fstat(PerlIO_fileno(rsfp),&statbuf); /* may be either wrapped or real suid */
if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
||
(egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
@@ -2371,7 +2371,7 @@ find_beginning(void)
/*SUPPRESS 530*/
while (s = moreswitches(s)) ;
}
- if (cddir && chdir(cddir) < 0)
+ if (cddir && PerlDir_chdir(cddir) < 0)
croak("Can't chdir to %s",cddir);
}
}
@@ -2618,7 +2618,7 @@ init_postdump_symbols(register int argc, register char **argv, register char **e
*s = '=';
#if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
/* Sins of the RTL. See note in my_setenv(). */
- (void)putenv(savepv(*env));
+ (void)PerlEnv_putenv(savepv(*env));
#endif
}
#endif
@@ -2637,11 +2637,11 @@ init_perllib(void)
char *s;
if (!tainting) {
#ifndef VMS
- s = getenv("PERL5LIB");
+ s = PerlEnv_getenv("PERL5LIB");
if (s)
incpush(s, TRUE);
else
- incpush(getenv("PERLLIB"), FALSE);
+ incpush(PerlEnv_getenv("PERLLIB"), FALSE);
#else /* VMS */
/* Treat PERL5?LIB as a possible search list logical name -- the
* "natural" VMS idiom for a Unix path string. We allow each
@@ -2861,7 +2861,7 @@ call_list(I32 oldscope, AV *list)
dJMPENV;
int ret;
- while (AvFILL(list) >= 0) {
+ while (AvFILL(list) >= 0) {
CV *cv = (CV*)av_shift(list);
SAVEFREESV(cv);
diff --git a/perl.h b/perl.h
index 820a6d2aed..9b521b9d3c 100644
--- a/perl.h
+++ b/perl.h
@@ -205,6 +205,11 @@ register struct op *op asm(stringify(OP_IN_REGISTER));
#endif
#include "perlio.h"
+#include "perllio.h"
+#include "perlsock.h"
+#include "perlproc.h"
+#include "perlenv.h"
+#include "perldir.h"
#ifdef USE_NEXT_CTYPE
@@ -945,7 +950,7 @@ typedef union any ANY;
typedef I32 (*filter_t) _((int, SV *, int));
#define FILTER_READ(idx, sv, len) filter_read(idx, sv, len)
#define FILTER_DATA(idx) (AvARRAY(rsfp_filters)[idx])
-#define FILTER_ISREADER(idx) (idx >= AvFILL(rsfp_filters))
+#define FILTER_ISREADER(idx) (idx >= AvFILLp(rsfp_filters))
#ifdef DOSISH
# if defined(OS2)
@@ -1256,7 +1261,7 @@ Gid_t getegid _((void));
if (!(what)) { \
croak("Assertion failed: file \"%s\", line %d", \
__FILE__, __LINE__); \
- exit(1); \
+ PerlProc_exit(1); \
}})
#endif
@@ -1751,7 +1756,7 @@ EXT MGVTBL vtbl_sigelem = {magic_getsig,
magic_setsig,
0, magic_clearsig,
0};
-EXT MGVTBL vtbl_pack = {0, 0, 0, magic_wipepack,
+EXT MGVTBL vtbl_pack = {0, 0, magic_sizepack, magic_wipepack,
0};
EXT MGVTBL vtbl_packelem = {magic_getpack,
magic_setpack,
diff --git a/perlsock.h b/perlsock.h
index e684fe2979..1a147f9479 100644
--- a/perlsock.h
+++ b/perlsock.h
@@ -3,10 +3,10 @@
#ifdef PERL_OBJECT
#else
-#define PerlSock_htonlx htonl(x)
-#define PerlSock_htonsx htons(x)
-#define PerlSock_ntohlx ntohl(x)
-#define PerlSock_ntohsx ntohs(x)
+#define PerlSock_htonl(x) htonl(x)
+#define PerlSock_htons(x) htons(x)
+#define PerlSock_ntohl(x) ntohl(x)
+#define PerlSock_ntohs(x) ntohs(x)
#define PerlSock_accept(s, a, l) accept(s, a, l)
#define PerlSock_bind(s, n, l) bind(s, n, l)
#define PerlSock_connect(s, n, l) connect(s, n, l)
diff --git a/pod/perlguts.pod b/pod/perlguts.pod
index 20a11ac45c..1db8249d24 100644
--- a/pod/perlguts.pod
+++ b/pod/perlguts.pod
@@ -57,7 +57,9 @@ calculate the length by using C<sv_setpv> or by specifying 0 as the second
argument to C<newSVpv>. Be warned, though, that Perl will determine the
string's length by using C<strlen>, which depends on the string terminating
with a NUL character. The arguments of C<sv_setpvf> are processed like
-C<sprintf>, and the formatted output becomes the value.
+C<sprintf>, and the formatted output becomes the value. The C<sv_set*()>
+functions are not generic enough to operate on values that have "magic".
+See L<Magic Virtual Tables> later in this document.
All SVs that will contain strings should, but need not, be terminated
with a NUL character. If it is not NUL-terminated there is a risk of
@@ -130,7 +132,9 @@ using C<strlen>. In the second, you specify the length of the string
yourself. The third function processes its arguments like C<sprintf> and
appends the formatted output. The fourth function extends the string
stored in the first SV with the string stored in the second SV. It also
-forces the second SV to be interpreted as a string.
+forces the second SV to be interpreted as a string. The C<sv_cat*()>
+functions are not generic enough to operate on values that have "magic".
+See L<Magic Virtual Tables> later in this document.
If you know the name of a scalar variable, you can get a pointer to its SV
by using the following:
@@ -831,6 +835,17 @@ as the extension is sufficient. For '~' magic, it may also be
appropriate to add an I32 'signature' at the top of the private data
area and check that.
+Also note that most of the C<sv_set*()> functions that modify scalars do
+B<not> invoke 'set' magic on their targets. This must be done by the user
+either by calling the C<SvSETMAGIC()> macro after calling these functions,
+or by using one of the C<SvSetMagic*()> macros. Similarly, generic C code
+must call the C<SvGETMAGIC()> macro to invoke any 'get' magic if they use
+an SV obtained from external sources in functions that don't handle magic.
+L<API LISTING> later in this document identifies such macros and functions.
+For example, calls to the C<sv_cat*()> functions typically need to be
+followed by C<SvSETMAGIC()>, but they don't need a prior C<SvGETMAGIC()>
+since their implementation handles 'get' magic.
+
=head2 Finding Magic
MAGIC* mg_find(SV*, int type); /* Finds the magic pointer of that type */
@@ -2324,28 +2339,29 @@ Opening bracket for arguments on a callback. See C<PUTBACK> and L<perlcall>.
=item PUSHi
Push an integer onto the stack. The stack must have room for this element.
-See C<XPUSHi>.
+Handles 'set' magic. See C<XPUSHi>.
PUSHi(int d)
=item PUSHn
Push a double onto the stack. The stack must have room for this element.
-See C<XPUSHn>.
+Handles 'set' magic. See C<XPUSHn>.
PUSHn(double d)
=item PUSHp
Push a string onto the stack. The stack must have room for this element.
-The C<len> indicates the length of the string. See C<XPUSHp>.
+The C<len> indicates the length of the string. Handles 'set' magic. See
+C<XPUSHp>.
PUSHp(char *c, int len )
=item PUSHs
-Push an SV onto the stack. The stack must have room for this element. See
-C<XPUSHs>.
+Push an SV onto the stack. The stack must have room for this element. Does
+not handle 'set' magic. See C<XPUSHs>.
PUSHs(sv)
@@ -2492,30 +2508,39 @@ of the SV is unaffected.
SV* sv_bless _((SV* sv, HV* stash));
+=item SvCatMagicPV
+
+=item SvCatMagicPVN
+
+=item SvCatMagicSV
+
=item sv_catpv
Concatenates the string onto the end of the string which is in the SV.
+Handles 'get' magic, but not 'set' magic. See C<SvCatMagicPV>.
void sv_catpv _((SV* sv, char* ptr));
=item sv_catpvn
Concatenates the string onto the end of the string which is in the SV. The
-C<len> indicates number of bytes to copy.
+C<len> indicates number of bytes to copy. Handles 'get' magic, but not
+'set' magic. See C<SvCatMagicPVN).
void sv_catpvn _((SV* sv, char* ptr, STRLEN len));
=item sv_catpvf
Processes its arguments like C<sprintf> and appends the formatted output
-to an SV.
+to an SV. Handles 'get' magic, but not 'set' magic. C<SvSETMAGIC()> must
+typically be called after calling this function to handle 'set' magic.
void sv_catpvf _((SV* sv, const char* pat, ...));
=item sv_catsv
Concatenates the string from SV C<ssv> onto the end of the string in SV
-C<dsv>.
+C<dsv>. Handles 'get' magic, but not 'set' magic. See C<SvCatMagicSV).
void sv_catsv _((SV* dsv, SV* ssv));
@@ -2559,6 +2584,13 @@ identical.
I32 sv_eq _((SV* sv1, SV* sv2));
+=item SvGETMAGIC
+
+Invokes C<mg_get> on an SV if it has 'get' magic. This macro evaluates
+its argument more than once.
+
+ void SvGETMAGIC( SV *sv )
+
=item SvGROW
Expands the character buffer in the SV. Calls C<sv_grow> to perform the
@@ -2776,7 +2808,7 @@ Checks the B<private> setting. Use C<SvPOK>.
Returns a pointer to the string in the SV, or a stringified form of the SV
if the SV does not contain a string. If C<len> is C<na> then Perl will
-handle the length on its own.
+handle the length on its own. Handles 'get' magic.
char * SvPV (SV* sv, int len )
@@ -2828,6 +2860,13 @@ Dereferences an RV to return the SV.
SV* SvRV (SV* sv);
+=item SvSETMAGIC
+
+Invokes C<mg_set> on an SV if it has 'set' magic. This macro evaluates
+its argument more than once.
+
+ void SvSETMAGIC( SV *sv )
+
=item SvTAINT
Taints an SV if tainting is enabled
@@ -2857,35 +2896,102 @@ Marks an SV as tainted.
SvTAINTED_on (SV* sv);
+=item SvSetMagicIV
+
+A macro that calls C<sv_setiv>, and invokes 'set' magic on the SV.
+May evaluate arguments more than once.
+
+ void SvSetMagicIV (SV* sv, IV num)
+
+=item SvSetMagicNV
+
+A macro that calls C<sv_setnv>, and invokes 'set' magic on the SV.
+May evaluate arguments more than once.
+
+ void SvSetMagicNV (SV* sv, double num)
+
+=item SvSetMagicPV
+
+A macro that calls C<sv_setpv>, and invokes 'set' magic on the SV.
+May evaluate arguments more than once.
+
+ void SvSetMagicPV (SV* sv, char *ptr)
+
+=item SvSetMagicPVIV
+
+A macro that calls C<sv_setpviv>, and invokes 'set' magic on the SV.
+May evaluate arguments more than once.
+
+ void SvSetMagicPVIV (SV* sv, IV num)
+
+=item SvSetMagicPVN
+
+A macro that calls C<sv_setpvn>, and invokes 'set' magic on the SV.
+May evaluate arguments more than once.
+
+ void SvSetMagicPVN (SV* sv, char* ptr, STRLEN len)
+
+=item SvSetMagicSV
+
+Same as C<SvSetSV>, but also invokes 'set' magic on the SV.
+May evaluate arguments more than once.
+
+ void SvSetMagicSV (SV* dsv, SV* ssv)
+
+=item SvSetMagicSV_nosteal
+
+Same as C<SvSetSV_nosteal>, but also invokes 'set' magic on the SV.
+May evaluate arguments more than once.
+
+ void SvSetMagicSV_nosteal (SV* dsv, SV* ssv)
+
+=item SvSetMagicUV
+
+A macro that calls C<sv_setuv>, and invokes 'set' magic on the SV.
+May evaluate arguments more than once.
+
+ void SvSetMagicUV (SV* sv, UV num)
+
=item sv_setiv
-Copies an integer into the given SV.
+Copies an integer into the given SV. Does not handle 'set' magic.
+See C<SvSetMagicIV>.
void sv_setiv _((SV* sv, IV num));
=item sv_setnv
-Copies a double into the given SV.
+Copies a double into the given SV. Does not handle 'set' magic.
+See C<SvSetMagicNV>.
void sv_setnv _((SV* sv, double num));
=item sv_setpv
Copies a string into an SV. The string must be null-terminated.
+Does not handle 'set' magic. See C<SvSetMagicPV>.
void sv_setpv _((SV* sv, char* ptr));
+=item sv_setpviv
+
+Copies an integer into the given SV, also updating its string value.
+Does not handle 'set' magic. See C<SvSetMagicPVIV>.
+
+ void sv_setpviv _((SV* sv, IV num));
+
=item sv_setpvn
Copies a string into an SV. The C<len> parameter indicates the number of
-bytes to be copied.
+bytes to be copied. Does not handle 'set' magic. See C<SvSetMagicPVN>.
void sv_setpvn _((SV* sv, char* ptr, STRLEN len));
=item sv_setpvf
Processes its arguments like C<sprintf> and sets an SV to the formatted
-output.
+output. Does not handle 'set' magic. C<SvSETMAGIC()> must typically
+be called after calling this function to handle 'set' magic.
void sv_setpvf _((SV* sv, const char* pat, ...));
@@ -2938,13 +3044,36 @@ a reference count of 1.
Note that C<sv_setref_pv> copies the pointer while this copies the string.
+=item SvSetSV
+
+Calls C<sv_setsv> if dsv is not the same as ssv. May evaluate arguments
+more than once.
+
+ void SvSetSV (SV* dsv, SV* ssv)
+
+=item SvSetSV_nosteal
+
+Calls a non-destructive version of C<sv_setsv> if dsv is not the same as ssv.
+May evaluate arguments more than once.
+
+ void SvSetSV_nosteal (SV* dsv, SV* ssv)
+
=item sv_setsv
Copies the contents of the source SV C<ssv> into the destination SV C<dsv>.
-The source SV may be destroyed if it is mortal.
+The source SV may be destroyed if it is mortal. Does not handle 'set' magic.
+See the macro forms C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
+C<SvSetMagicSV_nosteal>.
void sv_setsv _((SV* dsv, SV* ssv));
+=item sv_setuv
+
+Copies an unsigned integer into the given SV. Does not handle 'set' magic.
+See C<SvSetMagicUV>.
+
+ void sv_setuv _((SV* sv, UV num));
+
=item SvSTASH
Returns the stash of the SV.
@@ -2982,7 +3111,7 @@ Double type flag for scalars. See C<svtype>.
=item SvTRUE
Returns a boolean indicating whether Perl would evaluate the SV as true or
-false, defined or undefined.
+false, defined or undefined. Does not handle 'get' magic.
int SvTRUE (SV* sv)
@@ -3020,6 +3149,8 @@ as a reversal of C<newSVrv>. See C<SvROK_off>.
void sv_unref _((SV* sv));
+=item SvUseMagicPVN
+
=item sv_usepvn
Tells an SV to use C<ptr> to find its string value. Normally the string is
@@ -3027,7 +3158,8 @@ stored inside the SV but sv_usepvn allows the SV to use an outside string.
The C<ptr> should point to memory that was allocated by C<malloc>. The
string length, C<len>, must be supplied. This function will realloc the
memory pointed to by C<ptr>, so that pointer should not be freed or used by
-the programmer after giving it to sv_usepvn.
+the programmer after giving it to sv_usepvn. Does not handle 'set' magic.
+See C<SvUseMagicPVN>.
void sv_usepvn _((SV* sv, char* ptr, STRLEN len));
@@ -3060,28 +3192,29 @@ function the same way you use the C C<printf> function. See C<croak()>.
=item XPUSHi
-Push an integer onto the stack, extending the stack if necessary. See
-C<PUSHi>.
+Push an integer onto the stack, extending the stack if necessary. Handles
+'set' magic. See C<PUSHi>.
XPUSHi(int d)
=item XPUSHn
-Push a double onto the stack, extending the stack if necessary. See
-C<PUSHn>.
+Push a double onto the stack, extending the stack if necessary. Handles 'set'
+magic. See C<PUSHn>.
XPUSHn(double d)
=item XPUSHp
Push a string onto the stack, extending the stack if necessary. The C<len>
-indicates the length of the string. See C<PUSHp>.
+indicates the length of the string. Handles 'set' magic. See C<PUSHp>.
XPUSHp(char *c, int len)
=item XPUSHs
-Push an SV onto the stack, extending the stack if necessary. See C<PUSHs>.
+Push an SV onto the stack, extending the stack if necessary. Does not
+handle 'set' magic. See C<PUSHs>.
XPUSHs(sv)
@@ -3204,8 +3337,8 @@ Jeff Okamoto <F<okamoto@corp.hp.com>>
With lots of help and suggestions from Dean Roehrich, Malcolm Beattie,
Andreas Koenig, Paul Hudson, Ilya Zakharevich, Paul Marquess, Neil
-Bowers, Matthew Green, Tim Bunce, Spider Boardman, Ulrich Pfeifer, and
-Stephen McCamant.
+Bowers, Matthew Green, Tim Bunce, Spider Boardman, Ulrich Pfeifer,
+Stephen McCamant, and Gurusamy Sarathy.
API Listing by Dean Roehrich <F<roehrich@cray.com>>.
diff --git a/pod/perltie.pod b/pod/perltie.pod
index c6eb7156ce..79a749e68a 100644
--- a/pod/perltie.pod
+++ b/pod/perltie.pod
@@ -180,17 +180,26 @@ TIESCALAR classes are certainly possible.
=head2 Tying Arrays
A class implementing a tied ordinary array should define the following
-methods: TIEARRAY, FETCH, STORE, and perhaps DESTROY.
+methods: TIEARRAY, FETCH, STORE, FETCHSIZE, STORESIZE and perhaps DESTROY.
-B<WARNING>: Tied arrays are I<incomplete>. They are also distinctly lacking
-something for the C<$#ARRAY> access (which is hard, as it's an lvalue), as
-well as the other obvious array functions, like push(), pop(), shift(),
-unshift(), and splice().
+FETCHSIZE and STORESIZE are used to provide C<$#array> and
+equivalent C<scalar(@array)> access.
+
+The methods POP, PUSH, SHIFT, UNSHIFT, SPLICE are required if the perl
+operator with the corresponding (but lowercase) name is to operate on the
+tied array. The B<Tie::Array> class can be used as a base class to implement
+these in terms of the basic five methods above.
+
+In addition EXTEND will be called when perl would have pre-extended
+allocation in a real array.
+
+This means that tied arrays are now I<complete>. The example below needs
+upgrading to illustrate this. (The documentation in B<Tie::Array> is more
+complete.)
For this discussion, we'll implement an array whose indices are fixed at
its creation. If you try to access anything beyond those bounds, you'll
-take an exception. (Well, if you access an individual element; an
-aggregate assignment would be missed.) For example:
+take an exception. For example:
require Bounded_Array;
tie @ary, 'Bounded_Array', 2;
diff --git a/pod/perlxs.pod b/pod/perlxs.pod
index 6629af2dd5..d257b196eb 100644
--- a/pod/perlxs.pod
+++ b/pod/perlxs.pod
@@ -268,14 +268,17 @@ be seen by Perl.
The OUTPUT: keyword will also allow an output parameter to
be mapped to a matching piece of code rather than to a
-typemap.
+typemap. The following duplicates the behavior of the
+typemap:
bool_t
rpcb_gettime(host,timep)
char *host
time_t &timep
OUTPUT:
- timep sv_setnv(ST(1), (double)timep);
+ timep SvSetMagicNV(ST(1), (double)timep);
+
+See L<perlguts> for details about C<SvSetMagicNV()>.
=head2 The CODE: Keyword
diff --git a/pod/perlxstut.pod b/pod/perlxstut.pod
index 9ebfe82a97..dfc56ffbf1 100644
--- a/pod/perlxstut.pod
+++ b/pod/perlxstut.pod
@@ -428,7 +428,7 @@ Let's now take a look at a portion of the .c file created for our extension.
} else {
arg = 0.0;
}
- sv_setnv(ST(0), (double)arg); /* XXXXX */
+ SvSetMagicNV(ST(0), (double)arg); /* XXXXX */
}
XSRETURN(1);
}
@@ -438,10 +438,10 @@ the typemap file, you'll see that doubles are of type T_DOUBLE. In the
INPUT section, an argument that is T_DOUBLE is assigned to the variable
arg by calling the routine SvNV on something, then casting it to double,
then assigned to the variable arg. Similarly, in the OUTPUT section,
-once arg has its final value, it is passed to the sv_setnv function to
-be passed back to the calling subroutine. These two functions are explained
-in L<perlguts>; we'll talk more later about what that "ST(0)" means in the
-section on the argument stack.
+once arg has its final value, it is passed to the SvSetMagicNV() macro
+(which calls the sv_setnv() function) to be passed back to the calling
+subroutine. These macros/functions are explained in L<perlguts>; we'll talk
+more later about what that "ST(0)" means in the section on the argument stack.
=head2 WARNING
diff --git a/pp.c b/pp.c
index 765f10b702..79d884d115 100644
--- a/pp.c
+++ b/pp.c
@@ -24,7 +24,7 @@
*/
#ifdef CXUX_BROKEN_CONSTANT_CONVERT
static double UV_MAX_cxux = ((double)UV_MAX);
-#endif
+#endif
/*
* Types used in bitwise operations.
@@ -141,7 +141,16 @@ PP(pp_padav)
if (GIMME == G_ARRAY) {
I32 maxarg = AvFILL((AV*)TARG) + 1;
EXTEND(SP, maxarg);
- Copy(AvARRAY((AV*)TARG), SP+1, maxarg, SV*);
+ if (SvMAGICAL(TARG)) {
+ U32 i;
+ for (i=0; i < maxarg; i++) {
+ SV **svp = av_fetch((AV*)TARG, i, FALSE);
+ SP[i+1] = (svp) ? *svp : &sv_undef;
+ }
+ }
+ else {
+ Copy(AvARRAY((AV*)TARG), SP+1, maxarg, SV*);
+ }
SP += maxarg;
}
else {
@@ -189,7 +198,7 @@ PP(pp_padany)
PP(pp_rv2gv)
{
djSP; dTOPss;
-
+
if (SvROK(sv)) {
wasref:
sv = SvRV(sv);
@@ -297,7 +306,7 @@ PP(pp_av2arylen)
PP(pp_pos)
{
djSP; dTARGET; dPOPss;
-
+
if (op->op_flags & OPf_MOD) {
if (SvTYPE(TARG) < SVt_PVLV) {
sv_upgrade(TARG, SVt_PVLV);
@@ -310,7 +319,7 @@ PP(pp_pos)
RETURN;
}
else {
- MAGIC* mg;
+ MAGIC* mg;
if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
mg = mg_find(sv, 'g');
@@ -374,7 +383,7 @@ PP(pp_srefgen)
djSP;
*SP = refto(*SP);
RETURN;
-}
+}
PP(pp_refgen)
{
@@ -422,7 +431,7 @@ PP(pp_ref)
sv = POPs;
if (sv && SvGMAGICAL(sv))
- mg_get(sv);
+ mg_get(sv);
if (!sv || !SvROK(sv))
RETPUSHNO;
@@ -628,7 +637,7 @@ PP(pp_chomp)
{
djSP; dMARK; dTARGET;
register I32 count = 0;
-
+
while (SP > MARK)
count += do_chomp(POPs);
PUSHi(count);
@@ -784,7 +793,7 @@ PP(pp_postdec)
PP(pp_pow)
{
- djSP; dATARGET; tryAMAGICbin(pow,opASSIGN);
+ djSP; dATARGET; tryAMAGICbin(pow,opASSIGN);
{
dPOPTOPnnrl;
SETn( pow( left, right) );
@@ -794,7 +803,7 @@ PP(pp_pow)
PP(pp_multiply)
{
- djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
+ djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
{
dPOPTOPnnrl;
SETn( left * right );
@@ -804,7 +813,7 @@ PP(pp_multiply)
PP(pp_divide)
{
- djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
+ djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
{
dPOPPOPnnrl;
double value;
@@ -937,7 +946,7 @@ PP(pp_repeat)
PP(pp_subtract)
{
- djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
+ djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
{
dPOPTOPnnrl_ul;
SETn( left - right );
@@ -947,7 +956,7 @@ PP(pp_subtract)
PP(pp_left_shift)
{
- djSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
+ djSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
{
IBW shift = POPi;
if (op->op_private & HINT_INTEGER) {
@@ -966,7 +975,7 @@ PP(pp_left_shift)
PP(pp_right_shift)
{
- djSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
+ djSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
{
IBW shift = POPi;
if (op->op_private & HINT_INTEGER) {
@@ -985,7 +994,7 @@ PP(pp_right_shift)
PP(pp_lt)
{
- djSP; tryAMAGICbinSET(lt,0);
+ djSP; tryAMAGICbinSET(lt,0);
{
dPOPnv;
SETs(boolSV(TOPn < value));
@@ -995,7 +1004,7 @@ PP(pp_lt)
PP(pp_gt)
{
- djSP; tryAMAGICbinSET(gt,0);
+ djSP; tryAMAGICbinSET(gt,0);
{
dPOPnv;
SETs(boolSV(TOPn > value));
@@ -1005,7 +1014,7 @@ PP(pp_gt)
PP(pp_le)
{
- djSP; tryAMAGICbinSET(le,0);
+ djSP; tryAMAGICbinSET(le,0);
{
dPOPnv;
SETs(boolSV(TOPn <= value));
@@ -1015,7 +1024,7 @@ PP(pp_le)
PP(pp_ge)
{
- djSP; tryAMAGICbinSET(ge,0);
+ djSP; tryAMAGICbinSET(ge,0);
{
dPOPnv;
SETs(boolSV(TOPn >= value));
@@ -1025,7 +1034,7 @@ PP(pp_ge)
PP(pp_ne)
{
- djSP; tryAMAGICbinSET(ne,0);
+ djSP; tryAMAGICbinSET(ne,0);
{
dPOPnv;
SETs(boolSV(TOPn != value));
@@ -1035,7 +1044,7 @@ PP(pp_ne)
PP(pp_ncmp)
{
- djSP; dTARGET; tryAMAGICbin(ncmp,0);
+ djSP; dTARGET; tryAMAGICbin(ncmp,0);
{
dPOPTOPnnrl;
I32 value;
@@ -1057,7 +1066,7 @@ PP(pp_ncmp)
PP(pp_slt)
{
- djSP; tryAMAGICbinSET(slt,0);
+ djSP; tryAMAGICbinSET(slt,0);
{
dPOPTOPssrl;
int cmp = ((op->op_private & OPpLOCALE)
@@ -1070,7 +1079,7 @@ PP(pp_slt)
PP(pp_sgt)
{
- djSP; tryAMAGICbinSET(sgt,0);
+ djSP; tryAMAGICbinSET(sgt,0);
{
dPOPTOPssrl;
int cmp = ((op->op_private & OPpLOCALE)
@@ -1083,7 +1092,7 @@ PP(pp_sgt)
PP(pp_sle)
{
- djSP; tryAMAGICbinSET(sle,0);
+ djSP; tryAMAGICbinSET(sle,0);
{
dPOPTOPssrl;
int cmp = ((op->op_private & OPpLOCALE)
@@ -1096,7 +1105,7 @@ PP(pp_sle)
PP(pp_sge)
{
- djSP; tryAMAGICbinSET(sge,0);
+ djSP; tryAMAGICbinSET(sge,0);
{
dPOPTOPssrl;
int cmp = ((op->op_private & OPpLOCALE)
@@ -1109,7 +1118,7 @@ PP(pp_sge)
PP(pp_seq)
{
- djSP; tryAMAGICbinSET(seq,0);
+ djSP; tryAMAGICbinSET(seq,0);
{
dPOPTOPssrl;
SETs(boolSV(sv_eq(left, right)));
@@ -1119,7 +1128,7 @@ PP(pp_seq)
PP(pp_sne)
{
- djSP; tryAMAGICbinSET(sne,0);
+ djSP; tryAMAGICbinSET(sne,0);
{
dPOPTOPssrl;
SETs(boolSV(!sv_eq(left, right)));
@@ -1142,16 +1151,16 @@ PP(pp_scmp)
PP(pp_bit_and)
{
- djSP; dATARGET; tryAMAGICbin(band,opASSIGN);
+ djSP; dATARGET; tryAMAGICbin(band,opASSIGN);
{
dPOPTOPssrl;
if (SvNIOKp(left) || SvNIOKp(right)) {
if (op->op_private & HINT_INTEGER) {
- IBW value = SvIV(left) & SvIV(right);
+ IBW value = SvIV(left) & SvIV(right);
SETi(BWi(value));
}
else {
- UBW value = SvUV(left) & SvUV(right);
+ UBW value = SvUV(left) & SvUV(right);
SETu(BWu(value));
}
}
@@ -1165,16 +1174,16 @@ PP(pp_bit_and)
PP(pp_bit_xor)
{
- djSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
+ djSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
{
dPOPTOPssrl;
if (SvNIOKp(left) || SvNIOKp(right)) {
if (op->op_private & HINT_INTEGER) {
- IBW value = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
+ IBW value = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
SETi(BWi(value));
}
else {
- UBW value = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
+ UBW value = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
SETu(BWu(value));
}
}
@@ -1188,16 +1197,16 @@ PP(pp_bit_xor)
PP(pp_bit_or)
{
- djSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
+ djSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
{
dPOPTOPssrl;
if (SvNIOKp(left) || SvNIOKp(right)) {
if (op->op_private & HINT_INTEGER) {
- IBW value = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
+ IBW value = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
SETi(BWi(value));
}
else {
- UBW value = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
+ UBW value = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
SETu(BWu(value));
}
}
@@ -1252,7 +1261,7 @@ PP(pp_not)
PP(pp_complement)
{
- djSP; dTARGET; tryAMAGICun(compl);
+ djSP; dTARGET; tryAMAGICun(compl);
{
dTOPss;
if (SvNIOKp(sv)) {
@@ -1295,7 +1304,7 @@ PP(pp_complement)
PP(pp_i_multiply)
{
- djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
+ djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
{
dPOPTOPiirl;
SETi( left * right );
@@ -1305,7 +1314,7 @@ PP(pp_i_multiply)
PP(pp_i_divide)
{
- djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
+ djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
{
dPOPiv;
if (value == 0)
@@ -1318,7 +1327,7 @@ PP(pp_i_divide)
PP(pp_i_modulo)
{
- djSP; dATARGET; tryAMAGICbin(mod,opASSIGN);
+ djSP; dATARGET; tryAMAGICbin(mod,opASSIGN);
{
dPOPTOPiirl;
if (!right)
@@ -1330,7 +1339,7 @@ PP(pp_i_modulo)
PP(pp_i_add)
{
- djSP; dATARGET; tryAMAGICbin(add,opASSIGN);
+ djSP; dATARGET; tryAMAGICbin(add,opASSIGN);
{
dPOPTOPiirl;
SETi( left + right );
@@ -1340,7 +1349,7 @@ PP(pp_i_add)
PP(pp_i_subtract)
{
- djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
+ djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
{
dPOPTOPiirl;
SETi( left - right );
@@ -1350,7 +1359,7 @@ PP(pp_i_subtract)
PP(pp_i_lt)
{
- djSP; tryAMAGICbinSET(lt,0);
+ djSP; tryAMAGICbinSET(lt,0);
{
dPOPTOPiirl;
SETs(boolSV(left < right));
@@ -1360,7 +1369,7 @@ PP(pp_i_lt)
PP(pp_i_gt)
{
- djSP; tryAMAGICbinSET(gt,0);
+ djSP; tryAMAGICbinSET(gt,0);
{
dPOPTOPiirl;
SETs(boolSV(left > right));
@@ -1370,7 +1379,7 @@ PP(pp_i_gt)
PP(pp_i_le)
{
- djSP; tryAMAGICbinSET(le,0);
+ djSP; tryAMAGICbinSET(le,0);
{
dPOPTOPiirl;
SETs(boolSV(left <= right));
@@ -1380,7 +1389,7 @@ PP(pp_i_le)
PP(pp_i_ge)
{
- djSP; tryAMAGICbinSET(ge,0);
+ djSP; tryAMAGICbinSET(ge,0);
{
dPOPTOPiirl;
SETs(boolSV(left >= right));
@@ -1390,7 +1399,7 @@ PP(pp_i_ge)
PP(pp_i_eq)
{
- djSP; tryAMAGICbinSET(eq,0);
+ djSP; tryAMAGICbinSET(eq,0);
{
dPOPTOPiirl;
SETs(boolSV(left == right));
@@ -1400,7 +1409,7 @@ PP(pp_i_eq)
PP(pp_i_ne)
{
- djSP; tryAMAGICbinSET(ne,0);
+ djSP; tryAMAGICbinSET(ne,0);
{
dPOPTOPiirl;
SETs(boolSV(left != right));
@@ -1410,7 +1419,7 @@ PP(pp_i_ne)
PP(pp_i_ncmp)
{
- djSP; dTARGET; tryAMAGICbin(ncmp,0);
+ djSP; dTARGET; tryAMAGICbin(ncmp,0);
{
dPOPTOPiirl;
I32 value;
@@ -1437,7 +1446,7 @@ PP(pp_i_negate)
PP(pp_atan2)
{
- djSP; dTARGET; tryAMAGICbin(atan2,0);
+ djSP; dTARGET; tryAMAGICbin(atan2,0);
{
dPOPTOPnnrl;
SETn(atan2(left, right));
@@ -1753,7 +1762,7 @@ PP(pp_substr)
rem -= pos;
}
if (fail < 0) {
- if (dowarn || lvalue)
+ if (dowarn || lvalue)
warn("substr outside of string");
RETPUSHUNDEF;
}
@@ -1781,7 +1790,7 @@ PP(pp_substr)
LvTYPE(TARG) = 'x';
LvTARG(TARG) = sv;
LvTARGOFF(TARG) = pos;
- LvTARGLEN(TARG) = rem;
+ LvTARGLEN(TARG) = rem;
}
}
PUSHs(TARG); /* avoid SvSETMAGIC here */
@@ -1813,8 +1822,8 @@ PP(pp_vec)
LvTYPE(TARG) = 'v';
LvTARG(TARG) = src;
- LvTARGOFF(TARG) = offset;
- LvTARGLEN(TARG) = size;
+ LvTARGOFF(TARG) = offset;
+ LvTARGLEN(TARG) = size;
}
if (len > srclen) {
if (size <= 8)
@@ -2198,7 +2207,7 @@ PP(pp_each)
HE *entry;
I32 gimme = GIMME_V;
I32 realhv = (SvTYPE(hash) == SVt_PVHV);
-
+
PUTBACK;
/* might clobber stack_sp */
entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
@@ -2446,13 +2455,25 @@ PP(pp_splice)
I32 after;
I32 diff;
SV **tmparyval = 0;
+ MAGIC *mg;
+
+ if (SvRMAGICAL(ary) && (mg = mg_find((SV*)ary,'P'))) {
+ *MARK-- = mg->mg_obj;
+ PUSHMARK(MARK);
+ PUTBACK;
+ ENTER;
+ perl_call_method("SPLICE",GIMME_V);
+ LEAVE;
+ SPAGAIN;
+ RETURN;
+ }
SP++;
if (++MARK < SP) {
offset = i = SvIVx(*MARK);
if (offset < 0)
- offset += AvFILL(ary) + 1;
+ offset += AvFILLp(ary) + 1;
else
offset -= curcop->cop_arybase;
if (offset < 0)
@@ -2469,9 +2490,9 @@ PP(pp_splice)
offset = 0;
length = AvMAX(ary) + 1;
}
- if (offset > AvFILL(ary) + 1)
- offset = AvFILL(ary) + 1;
- after = AvFILL(ary) + 1 - (offset + length);
+ if (offset > AvFILLp(ary) + 1)
+ offset = AvFILLp(ary) + 1;
+ after = AvFILLp(ary) + 1 - (offset + length);
if (after < 0) { /* not that much array */
length += after; /* offset+length now in array */
after = 0;
@@ -2519,7 +2540,7 @@ PP(pp_splice)
SvREFCNT_dec(*dst++); /* free them now */
}
}
- AvFILL(ary) += diff;
+ AvFILLp(ary) += diff;
/* pull up or down? */
@@ -2540,7 +2561,7 @@ PP(pp_splice)
dst = src + diff; /* diff is negative */
Move(src, dst, after, SV*);
}
- dst = &AvARRAY(ary)[AvFILL(ary)+1];
+ dst = &AvARRAY(ary)[AvFILLp(ary)+1];
/* avoid later double free */
}
i = -diff;
@@ -2574,15 +2595,15 @@ PP(pp_splice)
}
SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
AvMAX(ary) += diff;
- AvFILL(ary) += diff;
+ AvFILLp(ary) += diff;
}
else {
- if (AvFILL(ary) + diff >= AvMAX(ary)) /* oh, well */
- av_extend(ary, AvFILL(ary) + diff);
- AvFILL(ary) += diff;
+ if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
+ av_extend(ary, AvFILLp(ary) + diff);
+ AvFILLp(ary) += diff;
if (after) {
- dst = AvARRAY(ary) + AvFILL(ary);
+ dst = AvARRAY(ary) + AvFILLp(ary);
src = dst - diff;
for (i = after; i; i--) {
*dst-- = *src--;
@@ -2633,12 +2654,25 @@ PP(pp_push)
djSP; dMARK; dORIGMARK; dTARGET;
register AV *ary = (AV*)*++MARK;
register SV *sv = &sv_undef;
+ MAGIC *mg;
- for (++MARK; MARK <= SP; MARK++) {
- sv = NEWSV(51, 0);
- if (*MARK)
- sv_setsv(sv, *MARK);
- av_push(ary, sv);
+ if (SvRMAGICAL(ary) && (mg = mg_find((SV*)ary,'P'))) {
+ *MARK-- = mg->mg_obj;
+ PUSHMARK(MARK);
+ PUTBACK;
+ ENTER;
+ perl_call_method("PUSH",G_SCALAR|G_DISCARD);
+ LEAVE;
+ SPAGAIN;
+ }
+ else {
+ /* Why no pre-extend of ary here ? */
+ for (++MARK; MARK <= SP; MARK++) {
+ sv = NEWSV(51, 0);
+ if (*MARK)
+ sv_setsv(sv, *MARK);
+ av_push(ary, sv);
+ }
}
SP = ORIGMARK;
PUSHi( AvFILL(ary) + 1 );
@@ -2676,14 +2710,26 @@ PP(pp_unshift)
register AV *ary = (AV*)*++MARK;
register SV *sv;
register I32 i = 0;
+ MAGIC *mg;
+
+ if (SvRMAGICAL(ary) && (mg = mg_find((SV*)ary,'P'))) {
- av_unshift(ary, SP - MARK);
- while (MARK < SP) {
- sv = NEWSV(27, 0);
- sv_setsv(sv, *++MARK);
- (void)av_store(ary, i++, sv);
- }
+ *MARK-- = mg->mg_obj;
+ PUTBACK;
+ ENTER;
+ perl_call_method("UNSHIFT",G_SCALAR|G_DISCARD);
+ LEAVE;
+ SPAGAIN;
+ }
+ else {
+ av_unshift(ary, SP - MARK);
+ while (MARK < SP) {
+ sv = NEWSV(27, 0);
+ sv_setsv(sv, *++MARK);
+ (void)av_store(ary, i++, sv);
+ }
+ }
SP = ORIGMARK;
PUSHi( AvFILL(ary) + 1 );
RETURN;
@@ -3061,7 +3107,7 @@ PP(pp_unpack)
s += SIZE16;
#ifdef HAS_NTOHS
if (datumtype == 'n')
- aushort = ntohs(aushort);
+ aushort = PerlSock_ntohs(aushort);
#endif
#ifdef HAS_VTOHS
if (datumtype == 'v')
@@ -3079,7 +3125,7 @@ PP(pp_unpack)
sv = NEWSV(39, 0);
#ifdef HAS_NTOHS
if (datumtype == 'n')
- aushort = ntohs(aushort);
+ aushort = PerlSock_ntohs(aushort);
#endif
#ifdef HAS_VTOHS
if (datumtype == 'v')
@@ -3180,7 +3226,7 @@ PP(pp_unpack)
s += SIZE32;
#ifdef HAS_NTOHL
if (datumtype == 'N')
- aulong = ntohl(aulong);
+ aulong = PerlSock_ntohl(aulong);
#endif
#ifdef HAS_VTOHL
if (datumtype == 'V')
@@ -3200,7 +3246,7 @@ PP(pp_unpack)
s += SIZE32;
#ifdef HAS_NTOHL
if (datumtype == 'N')
- aulong = ntohl(aulong);
+ aulong = PerlSock_ntohl(aulong);
#endif
#ifdef HAS_VTOHL
if (datumtype == 'V')
@@ -3234,7 +3280,7 @@ PP(pp_unpack)
case 'w':
EXTEND(SP, len);
EXTEND_MORTAL(len);
- {
+ {
UV auv = 0;
U32 bytes = 0;
@@ -3528,7 +3574,7 @@ is_an_int(char *s, STRLEN l)
static int
div128(SV *pnum, bool *done)
/* must be '\0' terminated */
-
+
{
STRLEN len;
char *s = SvPV(pnum, len);
@@ -3810,7 +3856,7 @@ PP(pp_pack)
fromstr = NEXTFROM;
ashort = (I16)SvIV(fromstr);
#ifdef HAS_HTONS
- ashort = htons(ashort);
+ ashort = PerlSock_htons(ashort);
#endif
CAT16(cat, &ashort);
}
@@ -3876,7 +3922,7 @@ PP(pp_pack)
SV *norm;
STRLEN len;
bool done;
-
+
/* Copy string and check for compliance */
from = SvPV(fromstr, len);
if ((norm = is_an_int(from, len)) == NULL)
@@ -3922,7 +3968,7 @@ PP(pp_pack)
fromstr = NEXTFROM;
aulong = SvUV(fromstr);
#ifdef HAS_HTONL
- aulong = htonl(aulong);
+ aulong = PerlSock_htonl(aulong);
#endif
CAT32(cat, &aulong);
}
@@ -4020,6 +4066,7 @@ PP(pp_pack)
}
#undef NEXTFROM
+
PP(pp_split)
{
djSP; dTARG;
@@ -4043,6 +4090,8 @@ PP(pp_split)
AV *oldstack = curstack;
I32 gimme = GIMME_V;
I32 oldsave = savestack_ix;
+ I32 make_mortal = 1;
+ MAGIC *mg = (MAGIC *) NULL;
#ifdef DEBUGGING
Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
@@ -4068,15 +4117,24 @@ PP(pp_split)
ary = Nullav;
if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
realarray = 1;
- if (!AvREAL(ary)) {
- AvREAL_on(ary);
- for (i = AvFILL(ary); i >= 0; i--)
- AvARRAY(ary)[i] = &sv_undef; /* don't free mere refs */
- }
+ PUTBACK;
av_extend(ary,0);
av_clear(ary);
- /* temporarily switch stacks */
- SWITCHSTACK(curstack, ary);
+ SPAGAIN;
+ if (SvRMAGICAL(ary) && (mg = mg_find((SV *) ary, 'P'))) {
+ PUSHMARK(SP);
+ XPUSHs(mg->mg_obj);
+ }
+ else {
+ if (!AvREAL(ary)) {
+ AvREAL_on(ary);
+ for (i = AvFILLp(ary); i >= 0; i--)
+ AvARRAY(ary)[i] = &sv_undef; /* don't free mere refs */
+ }
+ /* temporarily switch stacks */
+ SWITCHSTACK(curstack, ary);
+ make_mortal = 0;
+ }
}
base = SP - stack_base;
orig = s;
@@ -4109,7 +4167,7 @@ PP(pp_split)
dstr = NEWSV(30, m-s);
sv_setpvn(dstr, s, m-s);
- if (!realarray)
+ if (make_mortal)
sv_2mortal(dstr);
XPUSHs(dstr);
@@ -4129,13 +4187,13 @@ PP(pp_split)
break;
dstr = NEWSV(30, m-s);
sv_setpvn(dstr, s, m-s);
- if (!realarray)
+ if (make_mortal)
sv_2mortal(dstr);
XPUSHs(dstr);
s = m;
}
}
- else if (rx->check_substr && !rx->nparens
+ else if (rx->check_substr && !rx->nparens
&& (rx->reganch & ROPT_CHECK_ALL)
&& !(rx->reganch & ROPT_ANCH)) {
i = SvCUR(rx->check_substr);
@@ -4148,7 +4206,7 @@ PP(pp_split)
break;
dstr = NEWSV(30, m-s);
sv_setpvn(dstr, s, m-s);
- if (!realarray)
+ if (make_mortal)
sv_2mortal(dstr);
XPUSHs(dstr);
s = m + 1;
@@ -4163,7 +4221,7 @@ PP(pp_split)
{
dstr = NEWSV(31, m-s);
sv_setpvn(dstr, s, m-s);
- if (!realarray)
+ if (make_mortal)
sv_2mortal(dstr);
XPUSHs(dstr);
s = m + i;
@@ -4187,7 +4245,7 @@ PP(pp_split)
m = rx->startp[0];
dstr = NEWSV(32, m-s);
sv_setpvn(dstr, s, m-s);
- if (!realarray)
+ if (make_mortal)
sv_2mortal(dstr);
XPUSHs(dstr);
if (rx->nparens) {
@@ -4200,7 +4258,7 @@ PP(pp_split)
}
else
dstr = NEWSV(33, 0);
- if (!realarray)
+ if (make_mortal)
sv_2mortal(dstr);
XPUSHs(dstr);
}
@@ -4208,16 +4266,17 @@ PP(pp_split)
s = rx->endp[0];
}
}
+
LEAVE_SCOPE(oldsave);
iters = (SP - stack_base) - base;
if (iters > maxiters)
DIE("Split loop");
-
+
/* keep field after final delim? */
if (s < strend || (iters && origlimit)) {
dstr = NEWSV(34, strend-s);
sv_setpvn(dstr, s, strend-s);
- if (!realarray)
+ if (make_mortal)
sv_2mortal(dstr);
XPUSHs(dstr);
iters++;
@@ -4226,18 +4285,37 @@ PP(pp_split)
while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
iters--, SP--;
}
+
if (realarray) {
- SWITCHSTACK(ary, oldstack);
- if (SvSMAGICAL(ary)) {
+ if (!mg) {
+ SWITCHSTACK(ary, oldstack);
+ if (SvSMAGICAL(ary)) {
+ PUTBACK;
+ mg_set((SV*)ary);
+ SPAGAIN;
+ }
+ if (gimme == G_ARRAY) {
+ EXTEND(SP, iters);
+ Copy(AvARRAY(ary), SP + 1, iters, SV*);
+ SP += iters;
+ RETURN;
+ }
+ }
+ else {
PUTBACK;
- mg_set((SV*)ary);
+ ENTER;
+ perl_call_method("PUSH",G_SCALAR|G_DISCARD);
+ LEAVE;
SPAGAIN;
- }
- if (gimme == G_ARRAY) {
- EXTEND(SP, iters);
- Copy(AvARRAY(ary), SP + 1, iters, SV*);
- SP += iters;
- RETURN;
+ if (gimme == G_ARRAY) {
+ /* EXTEND should not be needed - we just popped them */
+ EXTEND(SP, iters);
+ for (i=0; i < iters; i++) {
+ SV **svp = av_fetch(ary, i, FALSE);
+ PUSHs((svp) ? *svp : &sv_undef);
+ }
+ RETURN;
+ }
}
}
else {
@@ -4258,7 +4336,7 @@ unlock_condpair(void *svv)
{
dTHR;
MAGIC *mg = mg_find((SV*)svv, 'm');
-
+
if (!mg)
croak("panic: unlock_condpair unlocking non-mutex");
MUTEX_LOCK(MgMUTEXP(mg));
@@ -4279,7 +4357,7 @@ PP(pp_lock)
SV *retsv = sv;
#ifdef USE_THREADS
MAGIC *mg;
-
+
if (SvROK(sv))
sv = SvRV(sv);
diff --git a/pp.h b/pp.h
index 1914fcc5b5..ab4140c415 100644
--- a/pp.h
+++ b/pp.h
@@ -154,10 +154,10 @@
#define ARGTARG op->op_targ
#define MAXARG op->op_private
-#define SWITCHSTACK(f,t) AvFILL(f) = sp - stack_base; \
+#define SWITCHSTACK(f,t) AvFILLp(f) = sp - stack_base; \
stack_base = AvARRAY(t); \
stack_max = stack_base + AvMAX(t); \
- sp = stack_sp = stack_base + AvFILL(t); \
+ sp = stack_sp = stack_base + AvFILLp(t); \
curstack = t;
#define EXTEND_MORTAL(n) \
diff --git a/pp_ctl.c b/pp_ctl.c
index ae24601658..d0033bfd99 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -1214,10 +1214,10 @@ PP(pp_caller)
AvREAL_off(dbargs); /* XXX Should be REIFY */
}
- if (AvMAX(dbargs) < AvFILL(ary) + off)
- av_extend(dbargs, AvFILL(ary) + off);
- Copy(AvALLOC(ary), AvARRAY(dbargs), AvFILL(ary) + 1 + off, SV*);
- AvFILL(dbargs) = AvFILL(ary) + off;
+ if (AvMAX(dbargs) < AvFILLp(ary) + off)
+ av_extend(dbargs, AvFILLp(ary) + off);
+ Copy(AvALLOC(ary), AvARRAY(dbargs), AvFILLp(ary) + 1 + off, SV*);
+ AvFILLp(dbargs) = AvFILLp(ary) + off;
}
RETURN;
}
@@ -1348,7 +1348,7 @@ PP(pp_enteriter)
cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
else {
cx->blk_loop.iterary = curstack;
- AvFILL(curstack) = sp - stack_base;
+ AvFILLp(curstack) = sp - stack_base;
cx->blk_loop.iterix = MARK - stack_base;
}
@@ -1714,7 +1714,7 @@ PP(pp_goto)
if (cx->blk_sub.hasargs) { /* put @_ back onto stack */
AV* av = cx->blk_sub.argarray;
- items = AvFILL(av) + 1;
+ items = AvFILLp(av) + 1;
stack_sp++;
EXTEND(stack_sp, items); /* @_ could have been extended. */
Copy(AvARRAY(av), stack_sp, items, SV*);
@@ -1764,10 +1764,10 @@ PP(pp_goto)
else { /* save temporaries on recursion? */
if (CvDEPTH(cv) == 100 && dowarn)
sub_crush_depth(cv);
- if (CvDEPTH(cv) > AvFILL(padlist)) {
+ if (CvDEPTH(cv) > AvFILLp(padlist)) {
AV *newpad = newAV();
SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
- I32 ix = AvFILL((AV*)svp[1]);
+ I32 ix = AvFILLp((AV*)svp[1]);
svp = AvARRAY(svp[0]);
for ( ;ix > 0; ix--) {
if (svp[ix] != &sv_undef) {
@@ -1801,7 +1801,7 @@ PP(pp_goto)
AvFLAGS(av) = AVf_REIFY;
}
av_store(padlist, CvDEPTH(cv), (SV*)newpad);
- AvFILL(padlist) = CvDEPTH(cv);
+ AvFILLp(padlist) = CvDEPTH(cv);
svp = AvARRAY(padlist);
}
}
@@ -1809,7 +1809,7 @@ PP(pp_goto)
if (!cx->blk_sub.hasargs) {
AV* av = (AV*)curpad[0];
- items = AvFILL(av) + 1;
+ items = AvFILLp(av) + 1;
if (items) {
/* Mark is at the end of the stack. */
EXTEND(sp, items);
@@ -1849,7 +1849,7 @@ PP(pp_goto)
}
}
Copy(mark,AvARRAY(av),items,SV*);
- AvFILL(av) = items - 1;
+ AvFILLp(av) = items - 1;
while (items--) {
if (*mark)
@@ -2162,6 +2162,7 @@ doeval(int gimme, OP** startop)
HV *newstash;
CV *caller;
AV* comppadlist;
+ I32 i;
in_eval = 1;
@@ -2178,6 +2179,16 @@ doeval(int gimme, OP** startop)
SAVEI32(max_intro_pending);
caller = compcv;
+ for (i = cxstack_ix - 1; i >= 0; i--) {
+ PERL_CONTEXT *cx = &cxstack[i];
+ if (cx->cx_type == CXt_EVAL)
+ break;
+ else if (cx->cx_type == CXt_SUB) {
+ caller = cx->blk_sub.cv;
+ break;
+ }
+ }
+
SAVESPTR(compcv);
compcv = (CV*)NEWSV(1104,0);
sv_upgrade((SV *)compcv, SVt_PVCV);
@@ -2578,10 +2589,10 @@ PP(pp_leaveeval)
* (Note that the fact that compcv and friends are still set here
* is, AFAIK, an accident.) --Chip
*/
- if (AvFILL(comppad_name) >= 0) {
+ if (AvFILLp(comppad_name) >= 0) {
SV **svp = AvARRAY(comppad_name);
I32 ix;
- for (ix = AvFILL(comppad_name); ix >= 0; ix--) {
+ for (ix = AvFILLp(comppad_name); ix >= 0; ix--) {
SV *sv = svp[ix];
if (sv && sv != &sv_undef && *SvPVX(sv) == '&') {
SvREFCNT_dec(sv);
diff --git a/pp_hot.c b/pp_hot.c
index 7c320b37c4..6400d5f6eb 100644
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -183,8 +183,11 @@ PP(pp_padsv)
if (op->op_flags & OPf_MOD) {
if (op->op_private & OPpLVAL_INTRO)
SAVECLEARSV(curpad[op->op_targ]);
- else if (op->op_private & OPpDEREF)
+ else if (op->op_private & OPpDEREF) {
+ PUTBACK;
vivify_ref(curpad[op->op_targ], op->op_private & OPpDEREF);
+ SPAGAIN;
+ }
}
RETURN;
}
@@ -297,6 +300,9 @@ PP(pp_print)
gv = defoutgv;
if (SvRMAGICAL(gv) && (mg = mg_find((SV*)gv, 'q'))) {
if (MARK == ORIGMARK) {
+ /* If using default handle then we need to make space to
+ * pass object as 1st arg, so move other args up ...
+ */
MEXTEND(SP, 1);
++MARK;
Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
@@ -443,8 +449,17 @@ PP(pp_rv2av)
if (GIMME == G_ARRAY) {
I32 maxarg = AvFILL(av) + 1;
- EXTEND(SP, maxarg);
- Copy(AvARRAY(av), SP+1, maxarg, SV*);
+ EXTEND(SP, maxarg);
+ if (SvRMAGICAL(av)) {
+ U32 i;
+ for (i=0; i < maxarg; i++) {
+ SV **svp = av_fetch(av, i, FALSE);
+ SP[i+1] = (svp) ? *svp : &sv_undef;
+ }
+ }
+ else {
+ Copy(AvARRAY(av), SP+1, maxarg, SV*);
+ }
SP += maxarg;
}
else {
@@ -1044,7 +1059,7 @@ do_readline(void)
((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
but that's unsupported, so I don't want to do it now and
have it bite someone in the future. */
- strcat(tmpfnam,tmpnam(NULL));
+ strcat(tmpfnam,PerlLIO_tmpnam(NULL));
cp = SvPV(tmpglob,i);
for (; i; i--) {
if (cp[i] == ';') hasver = 1;
@@ -1378,7 +1393,9 @@ PP(pp_iter)
SvREFCNT_dec(*cx->blk_loop.itervar);
- if (sv = AvARRAY(av)[++cx->blk_loop.iterix])
+ if (sv = (SvMAGICAL(av))
+ ? *av_fetch(av, ++cx->blk_loop.iterix, FALSE)
+ : AvARRAY(av)[++cx->blk_loop.iterix])
SvTEMP_off(sv);
else
sv = &sv_undef;
@@ -1439,11 +1456,13 @@ PP(pp_subst)
else {
TARG = DEFSV;
EXTEND(SP,1);
- }
+ }
if (SvREADONLY(TARG)
|| (SvTYPE(TARG) > SVt_PVLV
&& !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG))))
croak(no_modify);
+ PUTBACK;
+
s = SvPV(TARG, len);
if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
force_on_match = 1;
@@ -1519,6 +1538,7 @@ PP(pp_subst)
if (c && clen <= rx->minlen && (once || !(safebase & REXEC_COPY_STR))
&& !(rx->reganch & ROPT_LOOKBEHIND_SEEN)) {
if (!regexec_flags(rx, s, strend, orig, 0, screamer, NULL, safebase)) {
+ SPAGAIN;
PUSHs(&sv_no);
LEAVE_SCOPE(oldsave);
RETURN;
@@ -1574,6 +1594,7 @@ PP(pp_subst)
sv_chop(TARG, d);
}
TAINT_IF(rxtainted);
+ SPAGAIN;
PUSHs(&sv_yes);
}
else {
@@ -1602,10 +1623,15 @@ PP(pp_subst)
Move(s, d, i+1, char); /* include the NUL */
}
TAINT_IF(rxtainted);
+ SPAGAIN;
PUSHs(sv_2mortal(newSViv((I32)iters)));
}
(void)SvPOK_only(TARG);
- SvSETMAGIC(TARG);
+ if (SvSMAGICAL(TARG)) {
+ PUTBACK;
+ mg_set(TARG);
+ SPAGAIN;
+ }
SvTAINT(TARG);
LEAVE_SCOPE(oldsave);
RETURN;
@@ -1618,11 +1644,12 @@ PP(pp_subst)
goto force_it;
}
rxtainted = RX_MATCH_TAINTED(rx);
- dstr = NEWSV(25, sv_len(TARG));
+ dstr = NEWSV(25, len);
sv_setpvn(dstr, m, s-m);
curpm = pm;
if (!c) {
register PERL_CONTEXT *cx;
+ SPAGAIN;
PUSHSUBST(cx);
RETURNOP(cPMOP->op_pmreplroot);
}
@@ -1660,6 +1687,7 @@ PP(pp_subst)
(void)SvPOK_only(TARG);
SvSETMAGIC(TARG);
SvTAINT(TARG);
+ SPAGAIN;
PUSHs(sv_2mortal(newSViv((I32)iters)));
LEAVE_SCOPE(oldsave);
RETURN;
@@ -1669,7 +1697,8 @@ PP(pp_subst)
nope:
++BmUSEFUL(rx->check_substr);
-ret_no:
+ret_no:
+ SPAGAIN;
PUSHs(&sv_no);
LEAVE_SCOPE(oldsave);
RETURN;
@@ -2038,7 +2067,7 @@ PP(pp_entersub)
#else
av = GvAV(defgv);
#endif /* USE_THREADS */
- items = AvFILL(av) + 1;
+ items = AvFILLp(av) + 1; /* @_ is not tieable */
if (items) {
/* Mark is at the end of the stack. */
@@ -2085,11 +2114,11 @@ PP(pp_entersub)
if (CvDEPTH(cv) == 100 && dowarn
&& !(PERLDB_SUB && cv == GvCV(DBsub)))
sub_crush_depth(cv);
- if (CvDEPTH(cv) > AvFILL(padlist)) {
+ if (CvDEPTH(cv) > AvFILLp(padlist)) {
AV *av;
AV *newpad = newAV();
SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
- I32 ix = AvFILL((AV*)svp[1]);
+ I32 ix = AvFILLp((AV*)svp[1]);
svp = AvARRAY(svp[0]);
for ( ;ix > 0; ix--) {
if (svp[ix] != &sv_undef) {
@@ -2119,7 +2148,7 @@ PP(pp_entersub)
av_store(newpad, 0, (SV*)av);
AvFLAGS(av) = AVf_REIFY;
av_store(padlist, CvDEPTH(cv), (SV*)newpad);
- AvFILL(padlist) = CvDEPTH(cv);
+ AvFILLp(padlist) = CvDEPTH(cv);
svp = AvARRAY(padlist);
}
}
@@ -2127,7 +2156,7 @@ PP(pp_entersub)
if (!hasargs) {
AV* av = (AV*)curpad[0];
- items = AvFILL(av) + 1;
+ items = AvFILLp(av) + 1;
if (items) {
/* Mark is at the end of the stack. */
EXTEND(sp, items);
@@ -2176,7 +2205,7 @@ PP(pp_entersub)
}
}
Copy(MARK,AvARRAY(av),items,SV*);
- AvFILL(av) = items - 1;
+ AvFILLp(av) = items - 1;
while (items--) {
if (*MARK)
diff --git a/pp_sys.c b/pp_sys.c
index 26886d1af1..a5de48bafe 100644
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -114,7 +114,7 @@ static int dooneliner _((char *cmd, char *filename));
# ifdef my_chsize /* Probably #defined to Perl_my_chsize in embed.h */
# undef my_chsize
# endif
-# define my_chsize chsize
+# define my_chsize PerlLIO_chsize
#endif
#ifdef HAS_FLOCK
@@ -183,7 +183,7 @@ PP(pp_backtick)
I32 gimme = GIMME_V;
TAINT_PROPER("``");
- fp = my_popen(tmps, "r");
+ fp = PerlProc_popen(tmps, "r");
if (fp) {
if (gimme == G_VOID) {
char tmpbuf[256];
@@ -216,7 +216,7 @@ PP(pp_backtick)
SvTAINTED_on(sv);
}
}
- STATUS_NATIVE_SET(my_pclose(fp));
+ STATUS_NATIVE_SET(PerlProc_pclose(fp));
TAINT; /* "I believe that this is not gratuitous!" */
}
else {
@@ -392,7 +392,7 @@ PP(pp_pipe_op)
if (IoIFP(wstio))
do_close(wgv, FALSE);
- if (pipe(fd) < 0)
+ if (PerlProc_pipe(fd) < 0)
goto badexit;
IoIFP(rstio) = PerlIO_fdopen(fd[0], "r");
@@ -403,9 +403,9 @@ PP(pp_pipe_op)
if (!IoIFP(rstio) || !IoOFP(wstio)) {
if (IoIFP(rstio)) PerlIO_close(IoIFP(rstio));
- else close(fd[0]);
+ else PerlLIO_close(fd[0]);
if (IoOFP(wstio)) PerlIO_close(IoOFP(wstio));
- else close(fd[1]);
+ else PerlLIO_close(fd[1]);
goto badexit;
}
@@ -440,11 +440,11 @@ PP(pp_umask)
#ifdef HAS_UMASK
if (MAXARG < 1) {
- anum = umask(0);
- (void)umask(anum);
+ anum = PerlLIO_umask(0);
+ (void)PerlLIO_umask(anum);
}
else
- anum = umask(POPi);
+ anum = PerlLIO_umask(POPi);
TAINT_PROPER("umask");
XPUSHi(anum);
#else
@@ -476,7 +476,7 @@ PP(pp_binmode)
else
RETPUSHUNDEF;
#else
- if (setmode(PerlIO_fileno(fp), OP_BINARY) != -1) {
+ if (PerlLIO_setmode(PerlIO_fileno(fp), OP_BINARY) != -1) {
#if defined(WIN32) && defined(__BORLANDC__)
/* The translation mode of the stream is maintained independent
* of the translation mode of the fd in the Borland RTL (heavy
@@ -516,62 +516,48 @@ PP(pp_tie)
SV **mark = stack_base + ++*markstack_ptr; /* reuse in entersub */
I32 markoff = mark - stack_base - 1;
char *methname;
-#ifdef ORIGINAL_TIE
- BINOP myop;
- bool oldcatch = CATCH_GET;
-#endif
-
- varsv = mark[0];
- if (SvTYPE(varsv) == SVt_PVHV)
- methname = "TIEHASH";
- else if (SvTYPE(varsv) == SVt_PVAV)
- methname = "TIEARRAY";
- else if (SvTYPE(varsv) == SVt_PVGV)
- methname = "TIEHANDLE";
- else
- methname = "TIESCALAR";
-
- stash = gv_stashsv(mark[1], FALSE);
- if (!stash || !(gv = gv_fetchmethod(stash, methname)))
- DIE("Can't locate object method \"%s\" via package \"%s\"",
- methname, SvPV(mark[1],na));
-
-#ifdef ORIGINAL_TIE
- Zero(&myop, 1, BINOP);
- myop.op_last = (OP *) &myop;
- myop.op_next = Nullop;
- myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
- CATCH_SET(TRUE);
+ int how = 'P';
- ENTER;
- SAVEOP();
- op = (OP *) &myop;
- if (PERLDB_SUB && curstash != debstash)
- op->op_private |= OPpENTERSUB_DB;
-
- XPUSHs((SV*)GvCV(gv));
- PUTBACK;
+ varsv = mark[0];
+ switch(SvTYPE(varsv)) {
+ case SVt_PVHV:
+ methname = "TIEHASH";
+ break;
+ case SVt_PVAV:
+ methname = "TIEARRAY";
+ break;
+ case SVt_PVGV:
+ methname = "TIEHANDLE";
+ how = 'q';
+ break;
+ default:
+ methname = "TIESCALAR";
+ how = 'q';
+ break;
+ }
- if (op = pp_entersub(ARGS))
- runops();
+ if (sv_isobject(mark[1])) {
+ ENTER;
+ perl_call_method(methname, G_SCALAR);
+ }
+ else {
+ /* Not clear why we don't call perl_call_method here too.
+ * perhaps to get different error message ?
+ */
+ stash = gv_stashsv(mark[1], FALSE);
+ if (!stash || !(gv = gv_fetchmethod(stash, methname))) {
+ DIE("Can't locate object method \"%s\" via package \"%s\"",
+ methname, SvPV(mark[1],na));
+ }
+ ENTER;
+ perl_call_sv((SV*)GvCV(gv), G_SCALAR);
+ }
SPAGAIN;
- CATCH_SET(oldcatch);
-#else
- ENTER;
- perl_call_sv((SV*)GvCV(gv), G_SCALAR);
- SPAGAIN;
-#endif
sv = TOPs;
if (sv_isobject(sv)) {
- if (SvTYPE(varsv) == SVt_PVHV || SvTYPE(varsv) == SVt_PVAV) {
- sv_unmagic(varsv, 'P');
- sv_magic(varsv, sv, 'P', Nullch, 0);
- }
- else {
- sv_unmagic(varsv, 'q');
- sv_magic(varsv, sv, 'q', Nullch, 0);
- }
+ sv_unmagic(varsv, how);
+ sv_magic(varsv, sv, how, Nullch, 0);
}
LEAVE;
SP = stack_base + markoff;
@@ -583,8 +569,7 @@ PP(pp_untie)
{
djSP;
SV * sv ;
-
- sv = POPs;
+ sv = POPs;
if (dowarn) {
MAGIC * mg ;
@@ -625,7 +610,6 @@ PP(pp_tied)
RETURN ;
}
}
-
RETPUSHUNDEF;
}
@@ -637,10 +621,6 @@ PP(pp_dbmopen)
HV* stash;
GV *gv;
SV *sv;
-#ifdef ORIGINAL_TIE
- BINOP myop;
- bool oldcatch = CATCH_GET;
-#endif
hv = (HV*)POPs;
@@ -655,24 +635,9 @@ PP(pp_dbmopen)
DIE("No dbm on this machine");
}
-#ifdef ORIGINAL_TIE
- Zero(&myop, 1, BINOP);
- myop.op_last = (OP *) &myop;
- myop.op_next = Nullop;
- myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
- CATCH_SET(TRUE);
-
- ENTER;
- SAVEOP();
- op = (OP *) &myop;
- if (PERLDB_SUB && curstash != debstash)
- op->op_private |= OPpENTERSUB_DB;
- PUTBACK;
- pp_pushmark(ARGS);
-#else
ENTER;
PUSHMARK(sp);
-#endif
+
EXTEND(sp, 5);
PUSHs(sv);
PUSHs(left);
@@ -681,51 +646,26 @@ PP(pp_dbmopen)
else
PUSHs(sv_2mortal(newSViv(O_RDWR)));
PUSHs(right);
-#ifdef ORIGINAL_TIE
- PUSHs((SV*)GvCV(gv));
- PUTBACK;
-
- if (op = pp_entersub(ARGS))
- runops();
-#else
PUTBACK;
perl_call_sv((SV*)GvCV(gv), G_SCALAR);
-#endif
SPAGAIN;
if (!sv_isobject(TOPs)) {
sp--;
-#ifdef ORIGINAL_TIE
- op = (OP *) &myop;
- PUTBACK;
- pp_pushmark(ARGS);
-#else
PUSHMARK(sp);
-#endif
-
PUSHs(sv);
PUSHs(left);
PUSHs(sv_2mortal(newSViv(O_RDONLY)));
PUSHs(right);
-#ifdef ORIGINAL_TIE
- PUSHs((SV*)GvCV(gv));
-#endif
PUTBACK;
-
-#ifdef ORIGINAL_TIE
- if (op = pp_entersub(ARGS))
- runops();
-#else
perl_call_sv((SV*)GvCV(gv), G_SCALAR);
-#endif
SPAGAIN;
}
-#ifdef ORIGINAL_TIE
- CATCH_SET(oldcatch);
-#endif
- if (sv_isobject(TOPs))
+ if (sv_isobject(TOPs)) {
+ sv_unmagic((SV *) hv, 'P');
sv_magic((SV*)hv, TOPs, 'P', Nullch, 0);
+ }
LEAVE;
RETURN;
}
@@ -835,7 +775,7 @@ PP(pp_sselect)
#endif
}
- nfound = select(
+ nfound = PerlSock_select(
maxlen * 8,
(Select_fd_set_t) fd_sets[1],
(Select_fd_set_t) fd_sets[2],
@@ -1298,7 +1238,7 @@ PP(pp_sysread)
#endif
buffer = SvGROW(bufsv, length+1);
/* 'offset' means 'flags' here */
- length = recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset,
+ length = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset,
(struct sockaddr *)namebuf, &bufsize);
if (length < 0)
RETPUSHUNDEF;
@@ -1329,7 +1269,7 @@ PP(pp_sysread)
Zero(buffer+bufsize, offset-bufsize, char);
}
if (op->op_type == OP_SYSREAD) {
- length = read(PerlIO_fileno(IoIFP(io)), buffer+offset, length);
+ length = PerlLIO_read(PerlIO_fileno(IoIFP(io)), buffer+offset, length);
}
else
#ifdef HAS_SOCKET__bad_code_maybe
@@ -1340,7 +1280,7 @@ PP(pp_sysread)
#else
bufsize = sizeof namebuf;
#endif
- length = recvfrom(PerlIO_fileno(IoIFP(io)), buffer+offset, length, 0,
+ length = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer+offset, length, 0,
(struct sockaddr *)namebuf, &bufsize);
}
else
@@ -1412,18 +1352,18 @@ PP(pp_send)
offset = 0;
if (length > blen - offset)
length = blen - offset;
- length = write(PerlIO_fileno(IoIFP(io)), buffer+offset, length);
+ length = PerlLIO_write(PerlIO_fileno(IoIFP(io)), buffer+offset, length);
}
#ifdef HAS_SOCKET
else if (SP > MARK) {
char *sockbuf;
STRLEN mlen;
sockbuf = SvPVx(*++MARK, mlen);
- length = sendto(PerlIO_fileno(IoIFP(io)), buffer, blen, length,
+ length = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen, length,
(struct sockaddr *)sockbuf, mlen);
}
else
- length = send(PerlIO_fileno(IoIFP(io)), buffer, blen, length);
+ length = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, length);
#else
else
@@ -1537,12 +1477,12 @@ PP(pp_truncate)
#else
{
int tmpfd;
- if ((tmpfd = open(name, O_RDWR)) < 0)
+ if ((tmpfd = PerlLIO_open(name, O_RDWR)) < 0)
result = 0;
else {
if (my_chsize(tmpfd, len) < 0)
result = 0;
- close(tmpfd);
+ PerlLIO_close(tmpfd);
}
}
#endif
@@ -1690,7 +1630,7 @@ PP(pp_socket)
do_close(gv, FALSE);
TAINT_PROPER("socket");
- fd = socket(domain, type, protocol);
+ fd = PerlSock_socket(domain, type, protocol);
if (fd < 0)
RETPUSHUNDEF;
IoIFP(io) = PerlIO_fdopen(fd, "r"); /* stdio gets confused about sockets */
@@ -1699,7 +1639,7 @@ PP(pp_socket)
if (!IoIFP(io) || !IoOFP(io)) {
if (IoIFP(io)) PerlIO_close(IoIFP(io));
if (IoOFP(io)) PerlIO_close(IoOFP(io));
- if (!IoIFP(io) && !IoOFP(io)) close(fd);
+ if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
RETPUSHUNDEF;
}
@@ -1735,7 +1675,7 @@ PP(pp_sockpair)
do_close(gv2, FALSE);
TAINT_PROPER("socketpair");
- if (socketpair(domain, type, protocol, fd) < 0)
+ if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
RETPUSHUNDEF;
IoIFP(io1) = PerlIO_fdopen(fd[0], "r");
IoOFP(io1) = PerlIO_fdopen(fd[0], "w");
@@ -1746,10 +1686,10 @@ PP(pp_sockpair)
if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
- if (!IoIFP(io1) && !IoOFP(io1)) close(fd[0]);
+ if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]);
if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
- if (!IoIFP(io2) && !IoOFP(io2)) close(fd[1]);
+ if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]);
RETPUSHUNDEF;
}
@@ -1774,7 +1714,7 @@ PP(pp_bind)
addr = SvPV(addrsv, len);
TAINT_PROPER("bind");
- if (bind(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
+ if (PerlSock_bind(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
RETPUSHYES;
else
RETPUSHUNDEF;
@@ -1804,7 +1744,7 @@ PP(pp_connect)
addr = SvPV(addrsv, len);
TAINT_PROPER("connect");
- if (connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
+ if (PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
RETPUSHYES;
else
RETPUSHUNDEF;
@@ -1830,7 +1770,7 @@ PP(pp_listen)
if (!io || !IoIFP(io))
goto nuts;
- if (listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
+ if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
RETPUSHYES;
else
RETPUSHUNDEF;
@@ -1873,7 +1813,7 @@ PP(pp_accept)
if (IoIFP(nstio))
do_close(ngv, FALSE);
- fd = accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *)&saddr, &len);
+ fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *)&saddr, &len);
if (fd < 0)
goto badexit;
IoIFP(nstio) = PerlIO_fdopen(fd, "r");
@@ -1882,7 +1822,7 @@ PP(pp_accept)
if (!IoIFP(nstio) || !IoOFP(nstio)) {
if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
- if (!IoIFP(nstio) && !IoOFP(nstio)) close(fd);
+ if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
goto badexit;
}
@@ -1913,7 +1853,7 @@ PP(pp_shutdown)
if (!io || !IoIFP(io))
goto nuts;
- PUSHi( shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
+ PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
RETURN;
nuts:
@@ -1968,7 +1908,7 @@ PP(pp_ssockopt)
SvCUR_set(sv,256);
*SvEND(sv) ='\0';
len = SvCUR(sv);
- if (getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
+ if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
goto nuts2;
SvCUR_set(sv, len);
*SvEND(sv) ='\0';
@@ -1986,7 +1926,7 @@ PP(pp_ssockopt)
buf = (char*)&aint;
len = sizeof(int);
}
- if (setsockopt(fd, lvl, optname, buf, len) < 0)
+ if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
goto nuts2;
PUSHs(&sv_yes);
}
@@ -2037,11 +1977,11 @@ PP(pp_getpeername)
fd = PerlIO_fileno(IoIFP(io));
switch (optype) {
case OP_GETSOCKNAME:
- if (getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
+ if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
goto nuts2;
break;
case OP_GETPEERNAME:
- if (getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
+ if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
goto nuts2;
#if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
{
@@ -2101,7 +2041,7 @@ PP(pp_stat)
statgv = tmpgv;
sv_setpv(statname, "");
laststatval = (GvIO(tmpgv) && IoIFP(GvIOp(tmpgv))
- ? Fstat(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), &statcache) : -1);
+ ? PerlLIO_fstat(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), &statcache) : -1);
}
if (laststatval < 0)
max = 0;
@@ -2121,7 +2061,7 @@ PP(pp_stat)
#ifdef HAS_LSTAT
laststype = op->op_type;
if (op->op_type == OP_LSTAT)
- laststatval = lstat(SvPV(statname, na), &statcache);
+ laststatval = PerlLIO_lstat(SvPV(statname, na), &statcache);
else
#endif
laststatval = Stat(SvPV(statname, na), &statcache);
@@ -2456,7 +2396,7 @@ PP(pp_fttty)
fd = atoi(tmps);
else
RETPUSHUNDEF;
- if (isatty(fd))
+ if (PerlLIO_isatty(fd))
RETPUSHYES;
RETPUSHNO;
}
@@ -2509,7 +2449,7 @@ PP(pp_fttext)
if (io && IoIFP(io)) {
if (! PerlIO_has_base(IoIFP(io)))
DIE("-T and -B not implemented on filehandles");
- laststatval = Fstat(PerlIO_fileno(IoIFP(io)), &statcache);
+ laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &statcache);
if (laststatval < 0)
RETPUSHUNDEF;
if (S_ISDIR(statcache.st_mode)) /* handle NFS glitch */
@@ -2545,20 +2485,20 @@ PP(pp_fttext)
laststatval = -1;
sv_setpv(statname, SvPV(sv, na));
#ifdef HAS_OPEN3
- i = open(SvPV(sv, na), O_RDONLY, 0);
+ i = PerlLIO_open3(SvPV(sv, na), O_RDONLY, 0);
#else
- i = open(SvPV(sv, na), 0);
+ i = PerlLIO_open(SvPV(sv, na), 0);
#endif
if (i < 0) {
if (dowarn && strchr(SvPV(sv, na), '\n'))
warn(warn_nl, "open");
RETPUSHUNDEF;
}
- laststatval = Fstat(i, &statcache);
+ laststatval = PerlLIO_fstat(i, &statcache);
if (laststatval < 0)
RETPUSHUNDEF;
- len = read(i, tbuf, 512);
- (void)close(i);
+ len = PerlLIO_read(i, tbuf, 512);
+ (void)PerlLIO_close(i);
if (len <= 0) {
if (S_ISDIR(statcache.st_mode) && op->op_type == OP_FTTEXT)
RETPUSHNO; /* special case NFS directories */
@@ -2617,7 +2557,7 @@ PP(pp_chdir)
tmps = SvPV(*svp, na);
}
TAINT_PROPER("chdir");
- PUSHi( chdir(tmps) >= 0 );
+ PUSHi( PerlDir_chdir(tmps) >= 0 );
#ifdef VMS
/* Clear the DEFAULT element of ENV so we'll get the new value
* in the future. */
@@ -2782,14 +2722,14 @@ char *filename;
*s++ = *filename++;
}
strcpy(s, " 2>&1");
- myfp = my_popen(cmdline, "r");
+ myfp = PerlProc_popen(cmdline, "r");
Safefree(cmdline);
if (myfp) {
SV *tmpsv = sv_newmortal();
/* Need to save/restore 'rs' ?? */
s = sv_gets(tmpsv, myfp, 0);
- (void)my_pclose(myfp);
+ (void)PerlProc_pclose(myfp);
if (s != Nullch) {
int e;
for (e = 1;
@@ -2862,12 +2802,12 @@ PP(pp_mkdir)
TAINT_PROPER("mkdir");
#ifdef HAS_MKDIR
- SETi( Mkdir(tmps, mode) >= 0 );
+ SETi( PerlDir_mkdir(tmps, mode) >= 0 );
#else
SETi( dooneliner("mkdir", tmps) );
- oldumask = umask(0);
- umask(oldumask);
- chmod(tmps, (mode & ~oldumask) & 0777);
+ oldumask = PerlLIO_umask(0);
+ PerlLIO_umask(oldumask);
+ PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
#endif
RETURN;
}
@@ -2880,7 +2820,7 @@ PP(pp_rmdir)
tmps = POPp;
TAINT_PROPER("rmdir");
#ifdef HAS_RMDIR
- XPUSHi( rmdir(tmps) >= 0 );
+ XPUSHi( PerlDir_rmdir(tmps) >= 0 );
#else
XPUSHi( dooneliner("rmdir", tmps) );
#endif
@@ -2901,8 +2841,8 @@ PP(pp_open_dir)
goto nope;
if (IoDIRP(io))
- closedir(IoDIRP(io));
- if (!(IoDIRP(io) = opendir(dirname)))
+ PerlDir_close(IoDIRP(io));
+ if (!(IoDIRP(io) = PerlDir_open(dirname)))
goto nope;
RETPUSHYES;
@@ -2932,7 +2872,7 @@ PP(pp_readdir)
if (GIMME == G_ARRAY) {
/*SUPPRESS 560*/
- while (dp = (Direntry_t *)readdir(IoDIRP(io))) {
+ while (dp = (Direntry_t *)PerlDir_read(IoDIRP(io))) {
#ifdef DIRNAMLEN
sv = newSVpv(dp->d_name, dp->d_namlen);
#else
@@ -2945,7 +2885,7 @@ PP(pp_readdir)
}
}
else {
- if (!(dp = (Direntry_t *)readdir(IoDIRP(io))))
+ if (!(dp = (Direntry_t *)PerlDir_read(IoDIRP(io))))
goto nope;
#ifdef DIRNAMLEN
sv = newSVpv(dp->d_name, dp->d_namlen);
@@ -2984,7 +2924,7 @@ PP(pp_telldir)
if (!io || !IoDIRP(io))
goto nope;
- PUSHi( telldir(IoDIRP(io)) );
+ PUSHi( PerlDir_tell(IoDIRP(io)) );
RETURN;
nope:
if (!errno)
@@ -3006,7 +2946,7 @@ PP(pp_seekdir)
if (!io || !IoDIRP(io))
goto nope;
- (void)seekdir(IoDIRP(io), along);
+ (void)PerlDir_seek(IoDIRP(io), along);
RETPUSHYES;
nope:
@@ -3028,7 +2968,7 @@ PP(pp_rewinddir)
if (!io || !IoDIRP(io))
goto nope;
- (void)rewinddir(IoDIRP(io));
+ (void)PerlDir_rewind(IoDIRP(io));
RETPUSHYES;
nope:
if (!errno)
@@ -3050,9 +2990,9 @@ PP(pp_closedir)
goto nope;
#ifdef VOID_CLOSEDIR
- closedir(IoDIRP(io));
+ PerlDir_close(IoDIRP(io));
#else
- if (closedir(IoDIRP(io)) < 0) {
+ if (PerlDir_close(IoDIRP(io)) < 0) {
IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
goto nope;
}
@@ -3179,7 +3119,7 @@ PP(pp_system)
else {
value = (I32)do_exec(SvPVx(sv_mortalcopy(*SP), na));
}
- _exit(-1);
+ PerlProc__exit(-1);
#else /* ! FORK or VMS or OS/2 */
if (op->op_flags & OPf_STACKED) {
SV *really = *++MARK;
@@ -3639,16 +3579,18 @@ PP(pp_ghostent)
register char **elem;
register SV *sv;
#if defined(HAS_GETHOSTENT) && !defined(DONT_DECLARE_STD)
- struct hostent *gethostbyname(const char *);
- struct hostent *gethostbyaddr(const Gethbadd_addr_t, Gethbadd_alen_t, int);
- struct hostent *gethostent(void);
+ struct hostent *PerlSock_gethostbyname(const char *);
+ struct hostent *PerlSock_gethostbyaddr(const Gethbadd_addr_t, Gethbadd_alen_t, int);
+#ifndef PerlSock_gethostent
+ struct hostent *PerlSock_gethostent(void);
+#endif
#endif
struct hostent *hent;
unsigned long len;
EXTEND(SP, 10);
if (which == OP_GHBYNAME) {
- hent = gethostbyname(POPp);
+ hent = PerlSock_gethostbyname(POPp);
}
else if (which == OP_GHBYADDR) {
int addrtype = POPi;
@@ -3656,11 +3598,11 @@ PP(pp_ghostent)
STRLEN addrlen;
Gethbadd_addr_t addr = (Gethbadd_addr_t) SvPV(addrsv, addrlen);
- hent = gethostbyaddr(addr, (Gethbadd_alen_t) addrlen, addrtype);
+ hent = PerlSock_gethostbyaddr(addr, (Gethbadd_alen_t) addrlen, addrtype);
}
else
#ifdef HAS_GETHOSTENT
- hent = gethostent();
+ hent = PerlSock_gethostent();
#else
DIE("gethostent not implemented");
#endif
@@ -3819,18 +3761,20 @@ PP(pp_gprotoent)
register char **elem;
register SV *sv;
#ifndef DONT_DECLARE_STD
- struct protoent *getprotobyname(const char *);
- struct protoent *getprotobynumber(int);
- struct protoent *getprotoent(void);
+ struct protoent *PerlSock_getprotobyname(const char *);
+ struct protoent *PerlSock_getprotobynumber(int);
+#ifndef PerlSock_getprotoent
+ struct protoent *PerlSock_getprotoent(void);
+#endif
#endif
struct protoent *pent;
if (which == OP_GPBYNAME)
- pent = getprotobyname(POPp);
+ pent = PerlSock_getprotobyname(POPp);
else if (which == OP_GPBYNUMBER)
- pent = getprotobynumber(POPi);
+ pent = PerlSock_getprotobynumber(POPi);
else
- pent = getprotoent();
+ pent = PerlSock_getprotoent();
EXTEND(SP, 3);
if (GIMME != G_ARRAY) {
@@ -3889,9 +3833,11 @@ PP(pp_gservent)
register char **elem;
register SV *sv;
#ifndef DONT_DECLARE_STD
- struct servent *getservbyname(const char *, const char *);
- struct servent *getservbynumber();
- struct servent *getservent(void);
+ struct servent *PerlSock_getservbyname(const char *, const char *);
+ struct servent *PerlSock_getservbynumber();
+#ifndef PerlSock_getservent
+ struct servent *PerlSock_getservent(void);
+#endif
#endif
struct servent *sent;
@@ -3902,19 +3848,19 @@ PP(pp_gservent)
if (proto && !*proto)
proto = Nullch;
- sent = getservbyname(name, proto);
+ sent = PerlSock_getservbyname(name, proto);
}
else if (which == OP_GSBYPORT) {
char *proto = POPp;
unsigned short port = POPu;
#ifdef HAS_HTONS
- port = htons(port);
+ port = PerlSock_htons(port);
#endif
- sent = getservbyport(port, proto);
+ sent = PerlSock_getservbyport(port, proto);
}
else
- sent = getservent();
+ sent = PerlSock_getservent();
EXTEND(SP, 4);
if (GIMME != G_ARRAY) {
@@ -3922,7 +3868,7 @@ PP(pp_gservent)
if (sent) {
if (which == OP_GSBYNAME) {
#ifdef HAS_NTOHS
- sv_setiv(sv, (IV)ntohs(sent->s_port));
+ sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
#else
sv_setiv(sv, (IV)(sent->s_port));
#endif
@@ -4443,9 +4389,9 @@ int operation;
/* flock locks entire file so for lockf we need to do the same */
save_errno = errno;
- pos = lseek(fd, (Off_t)0, SEEK_CUR); /* get pos to restore later */
+ pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR); /* get pos to restore later */
if (pos > 0) /* is seekable and needs to be repositioned */
- if (lseek(fd, (Off_t)0, SEEK_SET) < 0)
+ if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
pos = -1; /* seek failed, so don't seek back afterwards */
errno = save_errno;
@@ -4482,7 +4428,7 @@ int operation;
}
if (pos > 0) /* need to restore position of the handle */
- lseek(fd, pos, SEEK_SET); /* ignore error here */
+ PerlLIO_lseek(fd, pos, SEEK_SET); /* ignore error here */
return (i);
}
diff --git a/proto.h b/proto.h
index 67cebd143d..19159c5fd9 100644
--- a/proto.h
+++ b/proto.h
@@ -251,6 +251,7 @@ int magic_settaint _((SV* sv, MAGIC* mg));
int magic_setuvar _((SV* sv, MAGIC* mg));
int magic_setvec _((SV* sv, MAGIC* mg));
int magic_set_all_env _((SV* sv, MAGIC* mg));
+U32 magic_sizepack _((SV* sv, MAGIC* mg));
int magic_wipepack _((SV* sv, MAGIC* mg));
void magicname _((char* sym, char* name, I32 namlen));
int main _((int argc, char** argv, char** env));
@@ -267,6 +268,7 @@ int mg_get _((SV* sv));
U32 mg_len _((SV* sv));
void mg_magical _((SV* sv));
int mg_set _((SV* sv));
+I32 mg_size _((SV* sv));
OP* mod _((OP* o, I32 type));
char* moreswitches _((char* s));
OP* my _((OP* o));
diff --git a/regcomp.c b/regcomp.c
index 9039797ad4..bb1b86abef 100644
--- a/regcomp.c
+++ b/regcomp.c
@@ -750,7 +750,7 @@ pregcomp(char *exp, char *xend, PMOP *pm)
DEBUG_r(
if (!colorset) {
int i = 0;
- char *s = getenv("TERMCAP_COLORS");
+ char *s = PerlEnv_getenv("TERMCAP_COLORS");
colorset = 1;
if (s) {
diff --git a/scope.c b/scope.c
index 038b3912cf..350ed304f0 100644
--- a/scope.c
+++ b/scope.c
@@ -19,8 +19,16 @@ SV**
stack_grow(SV **sp, SV **p, int n)
{
dTHR;
+#if defined(DEBUGGING) && !defined(USE_THREADS)
+ static int growing = 0;
+ if (growing++)
+ abort();
+#endif
stack_sp = sp;
av_extend(curstack, (p - stack_base) + (n) + 128);
+#if defined(DEBUGGING) && !defined(USE_THREADS)
+ growing--;
+#endif
return stack_sp;
}
@@ -197,11 +205,14 @@ AV *
save_ary(GV *gv)
{
dTHR;
- AV *oav, *av;
+ AV *oav = GvAVn(gv);
+ AV *av;
+ if (!AvREAL(oav) && AvREIFY(oav))
+ av_reify(oav);
SSCHECK(3);
SSPUSHPTR(gv);
- SSPUSHPTR(oav = GvAVn(gv));
+ SSPUSHPTR(oav);
SSPUSHINT(SAVEt_AV);
GvAV(gv) = Null(AV*);
diff --git a/scope.h b/scope.h
index a65cb628a9..4648d00071 100644
--- a/scope.h
+++ b/scope.h
@@ -106,7 +106,7 @@ typedef struct jmpenv JMPENV;
STMT_START { \
cur_env.je_prev = top_env; \
OP_REG_TO_MEM; \
- cur_env.je_ret = Sigsetjmp(cur_env.je_buf, 1); \
+ cur_env.je_ret = PerlProc_setjmp(cur_env.je_buf, 1); \
OP_MEM_TO_REG; \
top_env = &cur_env; \
cur_env.je_mustcatch = FALSE; \
@@ -118,11 +118,11 @@ typedef struct jmpenv JMPENV;
STMT_START { \
OP_REG_TO_MEM; \
if (top_env->je_prev) \
- Siglongjmp(top_env->je_buf, (v)); \
+ PerlProc_longjmp(top_env->je_buf, (v)); \
if ((v) == 2) \
- exit(STATUS_NATIVE_EXPORT); \
+ PerlProc_exit(STATUS_NATIVE_EXPORT); \
PerlIO_printf(PerlIO_stderr(), "panic: top_env\n"); \
- exit(1); \
+ PerlProc_exit(1); \
} STMT_END
#define CATCH_GET (top_env->je_mustcatch)
diff --git a/sv.c b/sv.c
index 2ed06cd672..5b37d72df5 100644
--- a/sv.c
+++ b/sv.c
@@ -75,7 +75,7 @@ typedef void (*SVFUNC) _((SV*));
do { \
LOCK_SV_MUTEX; \
reg_remove(p); \
- free((char*)(p)); \
+ Safefree((char*)(p)); \
UNLOCK_SV_MUTEX; \
} while (0)
@@ -158,7 +158,7 @@ U32 size;
U32 flags;
{
if (!(flags & SVf_FAKE))
- free(ptr);
+ Safefree(ptr);
}
#else /* ! PURIFY */
@@ -541,7 +541,7 @@ more_xpv(void)
#ifdef PURIFY
#define new_XIV() (void*)safemalloc(sizeof(XPVIV))
-#define del_XIV(p) free((char*)p)
+#define del_XIV(p) Safefree((char*)p)
#else
#define new_XIV() (void*)new_xiv()
#define del_XIV(p) del_xiv((XPVIV*) p)
@@ -549,7 +549,7 @@ more_xpv(void)
#ifdef PURIFY
#define new_XNV() (void*)safemalloc(sizeof(XPVNV))
-#define del_XNV(p) free((char*)p)
+#define del_XNV(p) Safefree((char*)p)
#else
#define new_XNV() (void*)new_xnv()
#define del_XNV(p) del_xnv((XPVNV*) p)
@@ -557,7 +557,7 @@ more_xpv(void)
#ifdef PURIFY
#define new_XRV() (void*)safemalloc(sizeof(XRV))
-#define del_XRV(p) free((char*)p)
+#define del_XRV(p) Safefree((char*)p)
#else
#define new_XRV() (void*)new_xrv()
#define del_XRV(p) del_xrv((XRV*) p)
@@ -565,44 +565,44 @@ more_xpv(void)
#ifdef PURIFY
#define new_XPV() (void*)safemalloc(sizeof(XPV))
-#define del_XPV(p) free((char*)p)
+#define del_XPV(p) Safefree((char*)p)
#else
#define new_XPV() (void*)new_xpv()
#define del_XPV(p) del_xpv((XPV *)p)
#endif
#define new_XPVIV() (void*)safemalloc(sizeof(XPVIV))
-#define del_XPVIV(p) free((char*)p)
+#define del_XPVIV(p) Safefree((char*)p)
#define new_XPVNV() (void*)safemalloc(sizeof(XPVNV))
-#define del_XPVNV(p) free((char*)p)
+#define del_XPVNV(p) Safefree((char*)p)
#define new_XPVMG() (void*)safemalloc(sizeof(XPVMG))
-#define del_XPVMG(p) free((char*)p)
+#define del_XPVMG(p) Safefree((char*)p)
#define new_XPVLV() (void*)safemalloc(sizeof(XPVLV))
-#define del_XPVLV(p) free((char*)p)
+#define del_XPVLV(p) Safefree((char*)p)
#define new_XPVAV() (void*)safemalloc(sizeof(XPVAV))
-#define del_XPVAV(p) free((char*)p)
+#define del_XPVAV(p) Safefree((char*)p)
#define new_XPVHV() (void*)safemalloc(sizeof(XPVHV))
-#define del_XPVHV(p) free((char*)p)
+#define del_XPVHV(p) Safefree((char*)p)
#define new_XPVCV() (void*)safemalloc(sizeof(XPVCV))
-#define del_XPVCV(p) free((char*)p)
+#define del_XPVCV(p) Safefree((char*)p)
#define new_XPVGV() (void*)safemalloc(sizeof(XPVGV))
-#define del_XPVGV(p) free((char*)p)
+#define del_XPVGV(p) Safefree((char*)p)
#define new_XPVBM() (void*)safemalloc(sizeof(XPVBM))
-#define del_XPVBM(p) free((char*)p)
+#define del_XPVBM(p) Safefree((char*)p)
#define new_XPVFM() (void*)safemalloc(sizeof(XPVFM))
-#define del_XPVFM(p) free((char*)p)
+#define del_XPVFM(p) Safefree((char*)p)
#define new_XPVIO() (void*)safemalloc(sizeof(XPVIO))
-#define del_XPVIO(p) free((char*)p)
+#define del_XPVIO(p) Safefree((char*)p)
bool
sv_upgrade(register SV *sv, U32 mt)
@@ -785,7 +785,7 @@ sv_upgrade(register SV *sv, U32 mt)
Safefree(pv);
SvPVX(sv) = 0;
AvMAX(sv) = -1;
- AvFILL(sv) = -1;
+ AvFILLp(sv) = -1;
SvIVX(sv) = 0;
SvNVX(sv) = 0.0;
SvMAGIC(sv) = magic;
@@ -2983,7 +2983,7 @@ sv_collxfrm(SV *sv, STRLEN *nxp)
#endif /* USE_LOCALE_COLLATE */
char *
-sv_gets(register SV *sv, register FILE *fp, I32 append)
+sv_gets(register SV *sv, register PerlIO *fp, I32 append)
{
dTHR;
char *rsptr;
@@ -3703,8 +3703,6 @@ sv_true(register SV *sv)
dTHR;
if (!sv)
return 0;
- if (SvGMAGICAL(sv))
- mg_get(sv);
if (SvPOK(sv)) {
register XPV* tXpv;
if ((tXpv = (XPV*)SvANY(sv)) &&
@@ -3906,8 +3904,10 @@ newSVrv(SV *rv, char *classname)
SV*
sv_setref_pv(SV *rv, char *classname, void *pv)
{
- if (!pv)
+ if (!pv) {
sv_setsv(rv, &sv_undef);
+ SvSETMAGIC(rv);
+ }
else
sv_setiv(newSVrv(rv,classname), (IV)pv);
return rv;
@@ -4772,7 +4772,7 @@ sv_dump(SV *sv)
case SVt_PVAV:
PerlIO_printf(Perl_debug_log, " ARRAY = 0x%lx\n", (long)AvARRAY(sv));
PerlIO_printf(Perl_debug_log, " ALLOC = 0x%lx\n", (long)AvALLOC(sv));
- PerlIO_printf(Perl_debug_log, " FILL = %ld\n", (long)AvFILL(sv));
+ PerlIO_printf(Perl_debug_log, " FILL = %ld\n", (long)AvFILLp(sv));
PerlIO_printf(Perl_debug_log, " MAX = %ld\n", (long)AvMAX(sv));
PerlIO_printf(Perl_debug_log, " ARYLEN = 0x%lx\n", (long)AvARYLEN(sv));
flags = AvFLAGS(sv);
diff --git a/sv.h b/sv.h
index ffcc4aa22d..66fab163cd 100644
--- a/sv.h
+++ b/sv.h
@@ -611,23 +611,28 @@ struct xpvio {
# endif
#endif /* __GNUC__ */
-/* the following macro updates any magic values this sv is associated with */
+/* the following macros updates any magic values this sv is associated with */
-#define SvSETMAGIC(x) if (SvSMAGICAL(x)) mg_set(x)
+#define SvGETMAGIC(x) STMT_START { if (SvGMAGICAL(x)) mg_get(x); } STMT_END
+#define SvSETMAGIC(x) STMT_START { if (SvSMAGICAL(x)) mg_set(x); } STMT_END
#define SvSetSV_and(dst,src,finally) \
+ STMT_START { \
if ((dst) != (src)) { \
sv_setsv(dst, src); \
finally; \
- }
+ } \
+ } STMT_END
#define SvSetSV_nosteal_and(dst,src,finally) \
+ STMT_START { \
if ((dst) != (src)) { \
U32 tMpF = SvFLAGS(src) & SVs_TEMP; \
SvTEMP_off(src); \
sv_setsv(dst, src); \
SvFLAGS(src) |= tMpF; \
finally; \
- }
+ } \
+ } STMT_END
#define SvSetSV(dst,src) \
SvSetSV_and(dst,src,/*nothing*/;)
@@ -639,6 +644,27 @@ struct xpvio {
#define SvSetMagicSV_nosteal(dst,src) \
SvSetSV_nosteal_and(dst,src,SvSETMAGIC(dst))
+#define SvSetMagicPV(dst,s) \
+ STMT_START { sv_setpv(dst,s); SvSETMAGIC(dst); } STMT_END
+#define SvSetMagicPVN(dst,s,l) \
+ STMT_START { sv_setpvn(dst,s,l); SvSETMAGIC(dst); } STMT_END
+#define SvSetMagicIV(dst,i) \
+ STMT_START { sv_setiv(dst,i); SvSETMAGIC(dst); } STMT_END
+#define SvSetMagicPVIV(dst,i) \
+ STMT_START { sv_setpviv(dst,i); SvSETMAGIC(dst); } STMT_END
+#define SvSetMagicUV(dst,u) \
+ STMT_START { sv_setuv(dst,u); SvSETMAGIC(dst); } STMT_END
+#define SvSetMagicNV(dst,n) \
+ STMT_START { sv_setnv(dst,n); SvSETMAGIC(dst); } STMT_END
+#define SvCatMagicPV(dst,s) \
+ STMT_START { sv_catpv(dst,s); SvSETMAGIC(dst); } STMT_END
+#define SvCatMagicPVN(dst,s,l) \
+ STMT_START { sv_catpvn(dst,s,l); SvSETMAGIC(dst); } STMT_END
+#define SvCatMagicSV(dst,src) \
+ STMT_START { sv_catsv(dst,src); SvSETMAGIC(dst); } STMT_END
+#define SvUseMagicPVN(dst,s,l) \
+ STMT_START { sv_usepvn(dst,s,l); SvSETMAGIC(dst); } STMT_END
+
#define SvPEEK(sv) sv_peek(sv)
#define SvIMMORTAL(sv) ((sv)==&sv_undef || (sv)==&sv_yes || (sv)==&sv_no)
diff --git a/t/harness b/t/harness
index fe64a04629..af92a8b6dc 100644
--- a/t/harness
+++ b/t/harness
@@ -6,6 +6,7 @@
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
+ $ENV{PERL5LIB} = '../lib'; # so children will see it too
}
use lib '../lib';
diff --git a/t/lib/thread.t b/t/lib/thread.t
index 9810ae48d9..9810ae48d9 100755..100644
--- a/t/lib/thread.t
+++ b/t/lib/thread.t
diff --git a/t/op/avhv.t b/t/op/avhv.t
index 0390429d2b..a7ce58ab87 100755
--- a/t/op/avhv.t
+++ b/t/op/avhv.t
@@ -1,13 +1,23 @@
#!./perl
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+require Tie::Array;
-package Tie::StdArray;
+package Tie::BasicArray;
+@ISA = 'Tie::Array';
sub TIEARRAY { bless [], $_[0] }
-sub STORE { $_[0]->[$_[1]] = $_[2] }
-sub FETCH { $_[0]->[$_[1]] }
+sub STORE { $_[0]->[$_[1]] = $_[2] }
+sub FETCH { $_[0]->[$_[1]] }
+sub FETCHSIZE { scalar(@{$_[0]})}
+sub STORESIZE { $#{$_[0]} = $_[1]+1 }
package main;
-print "1..4\n";
+print "1..5\n";
$sch = {
'abc' => 1,
@@ -48,12 +58,19 @@ $a->[0] = $sch;
$a->{'abc'} = 'ABC';
if ($a->{'abc'} eq 'ABC') {print "ok 3\n";} else {print "not ok 3\n";}
+# quick check with tied array
+tie @fake, 'Tie::BasicArray';
+$a = \@fake;
+$a->[0] = $sch;
+
+$a->{'abc'} = 'ABC';
+if ($a->{'abc'} eq 'ABC') {print "ok 4\n";} else {print "not ok 4\n";}
+
# quick check with tied array & tied hash
-@INC = ("./lib", "../lib");
require Tie::Hash;
tie %fake, Tie::StdHash;
%fake = %$sch;
$a->[0] = \%fake;
$a->{'abc'} = 'ABC';
-if ($a->{'abc'} eq 'ABC') {print "ok 4\n";} else {print "not ok 4\n";}
+if ($a->{'abc'} eq 'ABC') {print "ok 5\n";} else {print "not ok 5\n";}
diff --git a/t/op/nothread.t b/t/op/nothread.t
index 7d42d276c8..7d42d276c8 100755..100644
--- a/t/op/nothread.t
+++ b/t/op/nothread.t
diff --git a/t/op/push.t b/t/op/push.t
index 68fab66af7..f62a4e9d8e 100755
--- a/t/op/push.t
+++ b/t/op/push.t
@@ -22,7 +22,7 @@ die "blech" unless @tests;
@x = (1,2,3);
push(@x,@x);
if (join(':',@x) eq '1:2:3:1:2:3') {print "ok 1\n";} else {print "not ok 1\n";}
-push(x,4);
+push(@x,4);
if (join(':',@x) eq '1:2:3:1:2:3:4') {print "ok 2\n";} else {print "not ok 2\n";}
$test = 3;
@@ -47,3 +47,4 @@ foreach $line (@tests) {
}
}
+1; # this file is require'd by lib/tie-stdpush.t
diff --git a/toke.c b/toke.c
index 6773f3f13c..51111d142f 100644
--- a/toke.c
+++ b/toke.c
@@ -389,7 +389,7 @@ skipspace(register char *s)
oldoldbufptr = oldbufptr = bufptr = s = linestart = SvPVX(linestr);
bufend = SvPVX(linestr) + SvCUR(linestr);
if (preprocess && !in_eval)
- (void)my_pclose(rsfp);
+ (void)PerlProc_pclose(rsfp);
else if ((PerlIO*)rsfp == PerlIO_stdin())
PerlIO_clearerr(rsfp);
else
@@ -1064,7 +1064,7 @@ static char*
incl_perldb(void)
{
if (perldb) {
- char *pdb = getenv("PERL5DB");
+ char *pdb = PerlEnv_getenv("PERL5DB");
if (pdb)
return pdb;
@@ -1120,10 +1120,10 @@ filter_del(filter_t funcp)
{
if (filter_debug)
warn("filter_del func %p", funcp);
- if (!rsfp_filters || AvFILL(rsfp_filters)<0)
+ if (!rsfp_filters || AvFILLp(rsfp_filters)<0)
return;
/* if filter is on top of stack (usual case) just pop it off */
- if (IoDIRP(FILTER_DATA(AvFILL(rsfp_filters))) == (void*)funcp){
+ if (IoDIRP(FILTER_DATA(AvFILLp(rsfp_filters))) == (void*)funcp){
sv_free(av_pop(rsfp_filters));
return;
@@ -1145,7 +1145,7 @@ filter_read(int idx, SV *buf_sv, int maxlen)
if (!rsfp_filters)
return -1;
- if (idx > AvFILL(rsfp_filters)){ /* Any more filters? */
+ if (idx > AvFILLp(rsfp_filters)){ /* Any more filters? */
/* Provide a default input filter to make life easy. */
/* Note that we append to the line. This is handy. */
if (filter_debug)
@@ -1195,7 +1195,7 @@ filter_read(int idx, SV *buf_sv, int maxlen)
static char *
-filter_gets(register SV *sv, register FILE *fp, STRLEN append)
+filter_gets(register SV *sv, register PerlIO *fp, STRLEN append)
{
#ifdef WIN32FILTER
if (!rsfp_filters) {
@@ -1503,7 +1503,7 @@ yylex(void)
if (SvCUR(linestr))
sv_catpv(linestr,";");
if (preambleav){
- while(AvFILL(preambleav) >= 0) {
+ while(AvFILLp(preambleav) >= 0) {
SV *tmpsv = av_shift(preambleav);
sv_catsv(linestr, tmpsv);
sv_catpv(linestr, ";");
@@ -1560,7 +1560,7 @@ yylex(void)
fake_eof:
if (rsfp) {
if (preprocess && !in_eval)
- (void)my_pclose(rsfp);
+ (void)PerlProc_pclose(rsfp);
else if ((PerlIO *)rsfp == PerlIO_stdin())
PerlIO_clearerr(rsfp);
else
diff --git a/universal.c b/universal.c
index 9a867631d0..67f96c381b 100644
--- a/universal.c
+++ b/universal.c
@@ -48,7 +48,8 @@ isa_lookup(HV *stash, char *name, int len, int level)
}
if(hv) {
SV** svp = AvARRAY(av);
- I32 items = AvFILL(av) + 1;
+ /* NOTE: No support for tied ISA */
+ I32 items = AvFILLp(av) + 1;
while (items--) {
SV* sv = *svp++;
HV* basestash = gv_stashsv(sv, FALSE);
diff --git a/util.c b/util.c
index bb82ad035e..dc0f4405d5 100644
--- a/util.c
+++ b/util.c
@@ -14,6 +14,7 @@
#include "EXTERN.h"
#include "perl.h"
+#include "perlmem.h"
#if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX)
#include <signal.h>
@@ -80,7 +81,7 @@ safemalloc(MEM_SIZE size)
if ((long)size < 0)
croak("panic: malloc");
#endif
- ptr = malloc(size?size:1); /* malloc(0) is NASTY on our system */
+ ptr = PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our system */
#if !(defined(I286) || defined(atarist))
DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%x: (%05d) malloc %ld bytes\n",ptr,an++,(long)size));
#else
@@ -105,7 +106,7 @@ saferealloc(Malloc_t where,MEM_SIZE size)
{
Malloc_t ptr;
#if !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE)
- Malloc_t realloc();
+ Malloc_t PerlMem_realloc();
#endif /* !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) */
#ifdef HAS_64K_LIMIT
@@ -121,7 +122,7 @@ saferealloc(Malloc_t where,MEM_SIZE size)
if ((long)size < 0)
croak("panic: realloc");
#endif
- ptr = realloc(where,size?size:1); /* realloc(0) is NASTY on our system */
+ ptr = PerlMem_realloc(where,size?size:1); /* realloc(0) is NASTY on our system */
#if !(defined(I286) || defined(atarist))
DEBUG_m( {
@@ -159,7 +160,7 @@ safefree(Malloc_t where)
#endif
if (where) {
/*SUPPRESS 701*/
- free(where);
+ PerlMem_free(where);
}
}
@@ -182,7 +183,7 @@ safecalloc(MEM_SIZE count, MEM_SIZE size)
croak("panic: calloc");
#endif
size *= count;
- ptr = malloc(size?size:1); /* malloc(0) is NASTY on our system */
+ ptr = PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our system */
#if !(defined(I286) || defined(atarist))
DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%x: (%05d) calloc %ld x %ld bytes\n",ptr,an++,(long)count,(long)size));
#else
@@ -532,8 +533,8 @@ perl_init_i18nl10n(int printwarn)
#ifdef USE_LOCALE_NUMERIC
char *curnum = NULL;
#endif /* USE_LOCALE_NUMERIC */
- char *lc_all = getenv("LC_ALL");
- char *lang = getenv("LANG");
+ char *lc_all = PerlEnv_getenv("LC_ALL");
+ char *lang = PerlEnv_getenv("LANG");
bool setlocale_failure = FALSE;
#ifdef LOCALE_ENVIRON_REQUIRED
@@ -557,19 +558,19 @@ perl_init_i18nl10n(int printwarn)
{
#ifdef USE_LOCALE_CTYPE
if (! (curctype = setlocale(LC_CTYPE,
- (!done && (lang || getenv("LC_CTYPE")))
+ (!done && (lang || PerlEnv_getenv("LC_CTYPE")))
? "" : Nullch)))
setlocale_failure = TRUE;
#endif /* USE_LOCALE_CTYPE */
#ifdef USE_LOCALE_COLLATE
if (! (curcoll = setlocale(LC_COLLATE,
- (!done && (lang || getenv("LC_COLLATE")))
+ (!done && (lang || PerlEnv_getenv("LC_COLLATE")))
? "" : Nullch)))
setlocale_failure = TRUE;
#endif /* USE_LOCALE_COLLATE */
#ifdef USE_LOCALE_NUMERIC
if (! (curnum = setlocale(LC_NUMERIC,
- (!done && (lang || getenv("LC_NUMERIC")))
+ (!done && (lang || PerlEnv_getenv("LC_NUMERIC")))
? "" : Nullch)))
setlocale_failure = TRUE;
#endif /* USE_LOCALE_NUMERIC */
@@ -616,7 +617,7 @@ perl_init_i18nl10n(int printwarn)
char *p;
bool locwarn = (printwarn > 1 ||
printwarn &&
- (!(p = getenv("PERL_BADLANG")) || atoi(p)));
+ (!(p = PerlEnv_getenv("PERL_BADLANG")) || atoi(p)));
if (locwarn) {
#ifdef LC_ALL
@@ -1451,7 +1452,7 @@ my_setenv(char *nam,char *val)
vallen = strlen(val);
New(904, envstr, namlen + vallen + 3, char);
(void)sprintf(envstr,"%s=%s",nam,val);
- (void)putenv(envstr);
+ (void)PerlEnv_putenv(envstr);
if (oldstr)
Safefree(oldstr);
#ifdef _MSC_VER
@@ -1508,7 +1509,7 @@ char *f;
{
I32 i;
- for (i = 0; unlink(f) >= 0; i++) ;
+ for (i = 0; PerlLIO_unlink(f) >= 0; i++) ;
return i ? 0 : -1;
}
#endif
@@ -1780,7 +1781,7 @@ my_popen(char *cmd, char *mode)
return my_syspopen(cmd,mode);
}
#endif
- if (pipe(p) < 0)
+ if (PerlProc_pipe(p) < 0)
return Nullfp;
This = (*mode == 'w');
that = !This;
@@ -1790,7 +1791,7 @@ my_popen(char *cmd, char *mode)
}
while ((pid = (doexec?vfork():fork())) < 0) {
if (errno != EAGAIN) {
- close(p[This]);
+ PerlLIO_close(p[This]);
if (!doexec)
croak("Can't fork");
return Nullfp;
@@ -1802,10 +1803,10 @@ my_popen(char *cmd, char *mode)
#define THIS that
#define THAT This
- close(p[THAT]);
+ PerlLIO_close(p[THAT]);
if (p[THIS] != (*mode == 'r')) {
- dup2(p[THIS], *mode == 'r');
- close(p[THIS]);
+ PerlLIO_dup2(p[THIS], *mode == 'r');
+ PerlLIO_close(p[THIS]);
}
if (doexec) {
#if !defined(HAS_FCNTL) || !defined(F_SETFD)
@@ -1815,10 +1816,10 @@ my_popen(char *cmd, char *mode)
#define NOFILE 20
#endif
for (fd = maxsysfd + 1; fd < NOFILE; fd++)
- close(fd);
+ PerlLIO_close(fd);
#endif
do_exec(cmd); /* may or may not use the shell */
- _exit(1);
+ PerlProc__exit(1);
}
/*SUPPRESS 560*/
if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
@@ -1830,10 +1831,10 @@ my_popen(char *cmd, char *mode)
#undef THAT
}
do_execfree(); /* free any memory malloced by child on vfork */
- close(p[that]);
+ PerlLIO_close(p[that]);
if (p[that] < p[This]) {
- dup2(p[This], p[that]);
- close(p[This]);
+ PerlLIO_dup2(p[This], p[that]);
+ PerlLIO_close(p[This]);
p[This] = p[that];
}
sv = *av_fetch(fdpid,p[This],TRUE);
@@ -1867,7 +1868,7 @@ char *s;
PerlIO_printf(PerlIO_stderr(),"%s", s);
for (fd = 0; fd < 32; fd++) {
- if (Fstat(fd,&tmpstatbuf) >= 0)
+ if (PerlLIO_fstat(fd,&tmpstatbuf) >= 0)
PerlIO_printf(PerlIO_stderr()," %d",fd);
}
PerlIO_printf(PerlIO_stderr(),"\n");
@@ -1883,7 +1884,7 @@ int newfd;
#if defined(HAS_FCNTL) && defined(F_DUPFD)
if (oldfd == newfd)
return oldfd;
- close(newfd);
+ PerlLIO_close(newfd);
return fcntl(oldfd, F_DUPFD, newfd);
#else
#define DUP2_MAX_FDS 256
@@ -1893,18 +1894,18 @@ int newfd;
if (oldfd == newfd)
return oldfd;
- close(newfd);
+ PerlLIO_close(newfd);
/* good enough for low fd's... */
- while ((fd = dup(oldfd)) != newfd && fd >= 0) {
+ while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) {
if (fdx >= DUP2_MAX_FDS) {
- close(fd);
+ PerlLIO_close(fd);
fd = -1;
break;
}
fdtmp[fdx++] = fd;
}
while (fdx > 0)
- close(fdtmp[--fdx]);
+ PerlLIO_close(fdtmp[--fdx]);
return fd;
#endif
}
@@ -1966,7 +1967,7 @@ rsignal_restore(int signo, Sigsave_t *save)
Sighandler_t
rsignal(int signo, Sighandler_t handler)
{
- return signal(signo, handler);
+ return PerlProc_signal(signo, handler);
}
static int sig_trapped;
@@ -1984,24 +1985,24 @@ rsignal_state(int signo)
Sighandler_t oldsig;
sig_trapped = 0;
- oldsig = signal(signo, sig_trap);
- signal(signo, oldsig);
+ oldsig = PerlProc_signal(signo, sig_trap);
+ PerlProc_signal(signo, oldsig);
if (sig_trapped)
- kill(getpid(), signo);
+ PerlProc_kill(getpid(), signo);
return oldsig;
}
int
rsignal_save(int signo, Sighandler_t handler, Sigsave_t *save)
{
- *save = signal(signo, handler);
+ *save = PerlProc_signal(signo, handler);
return (*save == SIG_ERR) ? -1 : 0;
}
int
rsignal_restore(int signo, Sigsave_t *save)
{
- return (signal(signo, *save) == SIG_ERR) ? -1 : 0;
+ return (PerlProc_signal(signo, *save) == SIG_ERR) ? -1 : 0;
}
#endif /* !HAS_SIGACTION */
@@ -2009,7 +2010,7 @@ rsignal_restore(int signo, Sigsave_t *save)
/* VMS' my_pclose() is in VMS.c; same with OS/2 */
#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS)
I32
-my_pclose(FILE *ptr)
+my_pclose(PerlIO *ptr)
{
Sigsave_t hstat, istat, qstat;
int status;
@@ -2043,7 +2044,7 @@ my_pclose(FILE *ptr)
#endif
}
#ifdef UTS
- if(kill(pid, 0) < 0) { return(pid); } /* HOM 12/23/91 */
+ if(PerlProc_kill(pid, 0) < 0) { return(pid); } /* HOM 12/23/91 */
#endif
rsignal_save(SIGHUP, SIG_IGN, &hstat);
rsignal_save(SIGINT, SIG_IGN, &istat);
@@ -2539,7 +2540,7 @@ new_struct_thread(struct perl_thread *t)
/* Initialise all per-thread SVs that the template thread used */
svp = AvARRAY(t->threadsv);
- for (i = 0; i <= AvFILL(t->threadsv); i++, svp++) {
+ for (i = 0; i <= AvFILLp(t->threadsv); i++, svp++) {
if (*svp && *svp != &sv_undef) {
SV *sv = newSVsv(*svp);
av_store(thr->threadsv, i, sv);
diff --git a/win32/Makefile b/win32/Makefile
index 12410e21fb..478137eea2 100644
--- a/win32/Makefile
+++ b/win32/Makefile
@@ -11,10 +11,10 @@
# newly built perl.
INST_DRV=c:
INST_TOP=$(INST_DRV)\perl5004.5x
-BUILDOPT=-DUSE_THREADS
-#BUILDOPT=-DMULTIPLICITY
-#BUILDOPT=-DMULTIPLICITY -DUSE_THREADS
-#BUILDOPT=-DPERL_GLOBAL_STRUCT -DMULTIPLICITY
+
+#
+# uncomment to enable threads-capabilities
+#USE_THREADS=-DUSE_THREADS
#
# uncomment next line if you are using Visual C++ 2.x
@@ -55,6 +55,24 @@ D_CRYPT=define
CRYPT_FLAG=-DHAVE_DES_FCRYPT
!ENDIF
+BUILDOPT = $(USE_THREADS)
+#BUILDOPT = $(USE_THREADS) -DMULTIPLICITY
+#BUILDOPT = $(USE_THREADS) -DPERL_GLOBAL_STRUCT -DMULTIPLICITY
+# -DUSE_PERLIO -D__STDC__=1 -DUSE_SFIO -DI_SFIO -I\sfio97\include
+
+!IF "$(PROCESSOR_ARCHITECTURE)" == ""
+PROCESSOR_ARCHITECTURE = x86
+!ENDIF
+
+!IF "$(USE_THREADS)" == ""
+ARCHNAME = MSWin32-$(PROCESSOR_ARCHITECTURE)
+!ELSE
+ARCHNAME = MSWin32-$(PROCESSOR_ARCHITECTURE)-thread
+!ENDIF
+
+ARCHDIR = ..\lib\$(ARCHNAME)
+COREDIR = ..\lib\CORE
+
#
# Programs to compile, build .lib files and link
#
@@ -121,12 +139,15 @@ o = .obj
.SUFFIXES : .c $(o) .dll .lib .exe
.c$(o):
- $(CC) -c $(CFLAGS) $(OBJOUT_FLAG)$@ $<
+ $(CC) -c -I$(<D) $(CFLAGS) $(OBJOUT_FLAG)$@ $<
$(o).dll:
$(LINK32) -dll -subsystem:windows -implib:$(*B).lib -def:$(*B).def \
-out:$@ $(LINK_FLAGS) $(LIBFILES) $< $(LIBPERL)
+.y.c:
+ $(NOOP)
+
#
INST_BIN=$(INST_TOP)\bin
INST_LIB=$(INST_TOP)\lib
@@ -146,6 +167,7 @@ PERLEXE=..\perl.exe
GLOBEXE=..\perlglob.exe
CONFIGPM=..\lib\Config.pm
MINIMOD=..\lib\ExtUtils\Miniperl.pm
+X2P=..\x2p\a2p.exe
PL2BAT=bin\pl2bat.pl
GLOBBAT = bin\perlglob.bat
@@ -156,6 +178,7 @@ CFGH_TMPL = config_H.vc
PERL95EXE=..\perl95.exe
XCOPY=xcopy /f /r /i /d
RCOPY=xcopy /f /r /i /e /d
+NOOP=@echo
NULL=
!IF "$(CRYPT_SRC)" != ""
@@ -241,6 +264,12 @@ PERL95_OBJ = perl95$(o) \
DLL_OBJ = perllib$(o) $(DYNALOADER)$(o)
+X2P_OBJ = ..\x2p\a2p$(o) \
+ ..\x2p\hash$(o) \
+ ..\x2p\str$(o) \
+ ..\x2p\util$(o) \
+ ..\x2p\walk$(o)
+
CORE_H = ..\av.h \
..\cop.h \
..\cv.h \
@@ -317,7 +346,8 @@ POD2TEXT=$(PODDIR)\pod2text
# Top targets
#
-all: $(PERLEXE) $(PERL95EXE) $(GLOBEXE) $(DYNALOADMODULES) $(MINIMOD) $(GLOBBAT)
+all: $(PERLEXE) $(PERL95EXE) $(GLOBEXE) $(DYNALOADMODULES) $(MINIMOD) \
+ $(X2P)
$(DYNALOADER)$(o) : $(DYNALOADER).c $(CORE_H) $(EXTDIR)\DynaLoader\dlutils.c
@@ -327,9 +357,6 @@ $(GLOBEXE): perlglob$(o)
$(LINK32) $(LINK_FLAGS) $(LIBFILES) -out:$@ -subsystem:$(SUBSYS) \
perlglob$(o) setargv$(o)
-$(GLOBBAT) : ..\lib\File\DosGlob.pm $(MINIPERL)
- $(MINIPERL) $(PL2BAT) - < ..\lib\File\DosGlob.pm > $(GLOBBAT)
-
perlglob$(o) : perlglob.c
..\miniperlmain$(o) : ..\miniperlmain.c $(CORE_H)
@@ -345,6 +372,7 @@ config.w32 : $(CFGSH_TMPL)
$(MINIPERL) -I..\lib config_sh.PL \
"INST_DRV=$(INST_DRV)" \
"INST_TOP=$(INST_TOP)" \
+ "archname=$(ARCHNAME)" \
"cc=$(CC)" \
"ccflags=$(OPTIMIZE) $(DEFINES)" \
"cf_email=$(EMAIL)" \
@@ -362,9 +390,9 @@ config.w32 : $(CFGSH_TMPL)
$(CONFIGPM) : $(MINIPERL) ..\config.sh config_h.PL ..\minimod.pl
cd .. && miniperl configpm
if exist lib\* $(RCOPY) lib\*.* ..\lib\$(NULL)
- $(XCOPY) ..\*.h ..\lib\CORE\*.*
- $(XCOPY) *.h ..\lib\CORE\*.*
- $(RCOPY) include ..\lib\CORE\*.*
+ $(XCOPY) ..\*.h $(COREDIR)\*.*
+ $(XCOPY) *.h $(COREDIR)\*.*
+ $(RCOPY) include $(COREDIR)\*.*
$(MINIPERL) -I..\lib config_h.PL || $(MAKE) CCTYPE=$(CCTYPE) \
RUNTIME=$(RUNTIME) CFG=$(CFG) $(CONFIGPM)
@@ -377,6 +405,7 @@ $(WIN32_OBJ) : $(CORE_H)
$(CORE_OBJ) : $(CORE_H)
$(DLL_OBJ) : $(CORE_H)
$(PERL95_OBJ) : $(CORE_H)
+$(X2P_OBJ) : $(CORE_H)
perldll.def : $(MINIPERL) $(CONFIGPM) ..\global.sym makedef.pl
$(MINIPERL) -w makedef.pl $(OPTIMIZE) $(DEFINES) \
@@ -386,7 +415,7 @@ $(PERLDLL): perldll.def $(CORE_OBJ) $(WIN32_OBJ) $(DLL_OBJ)
$(LINK32) -dll -def:perldll.def -out:$@ @<<
$(LINK_FLAGS) $(LIBFILES) $(CORE_OBJ) $(WIN32_OBJ) $(DLL_OBJ)
<<
- $(XCOPY) $(PERLIMPLIB) ..\lib\CORE
+ $(XCOPY) $(PERLIMPLIB) $(COREDIR)
perl.def : $(MINIPERL) makeperldef.pl
$(MINIPERL) -I..\lib makeperldef.pl $(NULL) > perl.def
@@ -394,6 +423,11 @@ perl.def : $(MINIPERL) makeperldef.pl
$(MINIMOD) : $(MINIPERL) ..\minimod.pl
cd .. && miniperl minimod.pl > lib\ExtUtils\Miniperl.pm
+$(X2P) : $(X2P_OBJ)
+ $(LINK32) -subsystem:console -out:$@ @<<
+ $(LINK_FLAGS) $(LIBFILES) $(X2P_OBJ)
+<<
+
perlmain.c : runperl.c
copy runperl.c perlmain.c
@@ -486,19 +520,19 @@ doc: $(PERLEXE)
$(XCOPY) *.bat ..\win32\bin\*.*
cd ..\win32
copy ..\README.win32 ..\pod\perlwin32.pod
- $(PERLEXE) ..\installhtml --podroot=.. --htmldir=./html \
+ $(PERLEXE) -I..\lib ..\installhtml --podroot=.. --htmldir=./html \
--podpath=pod:lib:ext:utils --htmlroot="//$(INST_HTML::=|)" \
--libpod=perlfunc:perlguts:perlvar:perlrun:perlop --recurse
utils: $(PERLEXE)
cd ..\utils
nmake PERL=$(MINIPERL)
- $(PERLEXE) ..\win32\$(PL2BAT) h2ph splain perlbug pl2pm c2ph
+ $(PERLEXE) -I..\lib ..\win32\$(PL2BAT) h2ph splain perlbug pl2pm c2ph
$(PERLEXE) ..\win32\$(PL2BAT) h2xs perldoc pstruct
$(XCOPY) *.bat ..\win32\bin\*.*
cd ..\win32
$(PERLEXE) $(PL2BAT) bin\network.pl bin\www.pl bin\runperl.pl \
- bin\pl2bat.pl
+ bin\pl2bat.pl bin\perlglob.pl
distclean: clean
-del /f $(MINIPERL) $(PERLEXE) $(PERL95EXE) $(PERLDLL) $(GLOBEXE) \
@@ -513,23 +547,18 @@ distclean: clean
-del /f ..\config.sh ..\splittree.pl perlmain.c dlutils.c \
config.h.new perl95.c
-del /f bin\*.bat
- -rmdir /s /q ..\lib\auto
- -rmdir /s /q ..\lib\CORE
+ -rmdir /s /q ..\lib\auto || rmdir /s ..\lib\auto
+ -rmdir /s /q $(COREDIR) || rmdir /s $(COREDIR)
cd $(EXTDIR)
-del /s *.lib *.def *.map *.bs Makefile *$(o) pm_to_blib
cd ..\win32
install : all doc utils
- if not exist $(INST_TOP) mkdir $(INST_TOP)
- echo I $(INST_TOP) L $(LIBDIR)
- $(XCOPY) $(PERLEXE) $(INST_BIN)\*.*
+ $(PERLEXE) ..\installperl
$(XCOPY) $(PERL95EXE) $(INST_BIN)\*.*
$(XCOPY) $(GLOBEXE) $(INST_BIN)\*.*
- $(XCOPY) $(PERLDLL) $(INST_BIN)\*.*
$(XCOPY) bin\*.bat $(INST_BIN)\*.*
- $(RCOPY) ..\lib $(INST_LIB)\*.*
$(XCOPY) ..\pod\*.bat $(INST_BIN)\*.*
- $(XCOPY) ..\pod\*.pod $(INST_POD)\*.*
$(RCOPY) html\*.* $(INST_HTML)\*.*
inst_lib : $(CONFIGPM)
@@ -537,7 +566,7 @@ inst_lib : $(CONFIGPM)
$(MINIPERL) -I..\lib ..\splittree.pl "../LIB" "../LIB/auto"
$(RCOPY) ..\lib $(INST_LIB)\*.*
-minitest : $(MINIPERL) $(GLOBEXE) $(CONFIGPM)
+minitest : $(MINIPERL) $(GLOBEXE) $(CONFIGPM) utils
$(XCOPY) $(MINIPERL) ..\t\perl.exe
$(XCOPY) $(GLOBEXE) ..\t\$(NULL)
attrib -r ..\t\*.*
@@ -546,7 +575,7 @@ minitest : $(MINIPERL) $(GLOBEXE) $(CONFIGPM)
$(MINIPERL) -I..\lib test base/*.t comp/*.t cmd/*.t io/*.t op/*.t pragma/*.t
cd ..\win32
-test-prep : all
+test-prep : all utils
$(XCOPY) $(PERLEXE) ..\t\$(NULL)
$(XCOPY) $(PERLDLL) ..\t\$(NULL)
$(XCOPY) $(GLOBEXE) ..\t\$(NULL)
@@ -575,8 +604,10 @@ clean :
-@erase $(CORE_OBJ)
-@erase $(WIN32_OBJ)
-@erase $(DLL_OBJ)
+ -@erase $(X2P_OBJ)
-@erase ..\*$(o) ..\*.lib ..\*.exp *$(o) *.lib *.exp
-@erase ..\t\*.exe ..\t\*.dll ..\t\*.bat
+ -@erase ..\x2p\*.exe ..\x2p\*.bat
-@erase *.ilk
-@erase *.pdb
diff --git a/win32/config.bc b/win32/config.bc
index 97cee6a476..b656184872 100644
--- a/win32/config.bc
+++ b/win32/config.bc
@@ -357,7 +357,7 @@ installbin='~INST_TOP~\bin'
installman1dir='~INST_TOP~\man\man1'
installman3dir='~INST_TOP~\man\man3'
installscript='~INST_TOP~\bin'
-installsitearch='~INST_TOP~\lib\site'
+installsitearch='~INST_TOP~\lib\site\~archname~'
installsitelib='~INST_TOP~\lib\site'
intsize='4'
known_extensions='DB_File Fcntl GDBM_File NDBM_File ODBM_File Opcode POSIX SDBM_File Socket IO attrs Thread'
@@ -369,6 +369,7 @@ ldflags=''
less='less'
lib_ext='.lib'
libc='cw32mti.lib'
+libperl='perl.lib'
libswanted='net socket inet nsl nm ndbm gdbm dbm db malloc dl dld ld sun m c cposix posix ndir dir crypt ucb bsd BSD PW x'
line='line'
lint=''
@@ -450,8 +451,8 @@ shortsize='2'
shrpdir='none'
sig_num='0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 6 18 22'
signal_t='void'
-sitearch='~INST_TOP~\lib\site'
-sitearchexp='~INST_TOP~\lib\site'
+sitearch='~INST_TOP~\lib\site\~archname~'
+sitearchexp='~INST_TOP~\lib\site\~archname~'
sitelib='~INST_TOP~\lib\site'
sitelibexp='~INST_TOP~\lib\site'
sizetype='size_t'
diff --git a/win32/config.gc b/win32/config.gc
index 3c9acbeda6..d32c1e91b8 100644
--- a/win32/config.gc
+++ b/win32/config.gc
@@ -5,7 +5,7 @@
## Target system: WIN32
#
-archlibexp='~INST_TOP~\lib'
+archlibexp='~INST_TOP~\lib\~archname~'
archname='MSWin32'
cc='gcc'
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='ar'
-archlib='~INST_TOP~\lib'
+archlib='~INST_TOP~\lib\~archname~'
archobjs=''
awk='awk'
baserev='5.0'
@@ -357,7 +357,7 @@ installbin='~INST_TOP~\bin'
installman1dir='~INST_TOP~\man\man1'
installman3dir='~INST_TOP~\man\man3'
installscript='~INST_TOP~\bin'
-installsitearch='~INST_TOP~\lib\site'
+installsitearch='~INST_TOP~\lib\site\~archname~'
installsitelib='~INST_TOP~\lib\site'
intsize='4'
known_extensions='DB_File Fcntl GDBM_File NDBM_File ODBM_File Opcode POSIX SDBM_File Socket IO attrs Thread'
@@ -369,6 +369,7 @@ ldflags=''
less='less'
lib_ext='.lib'
libc='msvcrt.lib'
+libperl='libperl.a'
libswanted='net socket inet nsl nm ndbm gdbm dbm db malloc dl dld ld sun m c cposix posix ndir dir crypt ucb bsd BSD PW x'
line='line'
lint=''
@@ -450,8 +451,8 @@ shortsize='2'
shrpdir='none'
sig_num='0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 6 18 22'
signal_t='void'
-sitearch='~INST_TOP~\lib\site'
-sitearchexp='~INST_TOP~\lib\site'
+sitearch='~INST_TOP~\lib\site\~archname~'
+sitearchexp='~INST_TOP~\lib\site\~archname~'
sitelib='~INST_TOP~\lib\site'
sitelibexp='~INST_TOP~\lib\site'
sizetype='size_t'
diff --git a/win32/config.vc b/win32/config.vc
index 09573225fb..a1b5bc34a0 100644
--- a/win32/config.vc
+++ b/win32/config.vc
@@ -5,7 +5,7 @@
## Target system: WIN32
#
-archlibexp='~INST_TOP~\lib'
+archlibexp='~INST_TOP~\lib\~archname~'
archname='MSWin32'
cc='cl'
ccflags='-MD -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='lib'
-archlib='~INST_TOP~\lib'
+archlib='~INST_TOP~\lib\~archname~'
archobjs=''
awk='awk'
baserev='5.0'
@@ -357,7 +357,7 @@ installbin='~INST_TOP~\bin'
installman1dir='~INST_TOP~\man\man1'
installman3dir='~INST_TOP~\man\man3'
installscript='~INST_TOP~\bin'
-installsitearch='~INST_TOP~\lib\site'
+installsitearch='~INST_TOP~\lib\site\~archname~'
installsitelib='~INST_TOP~\lib\site'
intsize='4'
known_extensions='DB_File Fcntl GDBM_File NDBM_File ODBM_File Opcode POSIX SDBM_File Socket IO attrs Thread'
@@ -369,6 +369,7 @@ ldflags='-nologo -subsystem:windows'
less='less'
lib_ext='.lib'
libc='msvcrt.lib'
+libperl='perl.lib'
libswanted='net socket inet nsl nm ndbm gdbm dbm db malloc dl dld ld sun m c cposix posix ndir dir crypt ucb bsd BSD PW x'
line='line'
lint=''
@@ -450,8 +451,8 @@ shortsize='2'
shrpdir='none'
sig_num='0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 6 18 22'
signal_t='void'
-sitearch='~INST_TOP~\lib\site'
-sitearchexp='~INST_TOP~\lib\site'
+sitearch='~INST_TOP~\lib\site\~archname~'
+sitearchexp='~INST_TOP~\lib\site\~archname~'
sitelib='~INST_TOP~\lib\site'
sitelibexp='~INST_TOP~\lib\site'
sizetype='size_t'
diff --git a/win32/config_sh.PL b/win32/config_sh.PL
index 5f3f157a0c..0c3713cb2e 100644
--- a/win32/config_sh.PL
+++ b/win32/config_sh.PL
@@ -5,17 +5,6 @@ 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/makefile.mk b/win32/makefile.mk
index 916d73c526..245d904439 100644
--- a/win32/makefile.mk
+++ b/win32/makefile.mk
@@ -16,13 +16,8 @@ INST_DRV *= c:
INST_TOP *= $(INST_DRV)\perl5004.5x
#
-#
-BUILDOPT *= -DUSE_THREADS
-#BUILDOPT *= -DMULTIPLICITY
-#BUILDOPT *=-DMULTIPLICITY -DUSE_THREADS
-#BUILDOPT *=-DPERL_GLOBAL_STRUCT -DMULTIPLICITY
-
-# -DUSE_PERLIO -D__STDC__=1 -DUSE_SFIO -DI_SFIO -I\sfio97\include
+# uncomment to enable threads-capabilities
+#USE_THREADS *= -DUSE_THREADS
#
# uncomment one
@@ -72,6 +67,24 @@ D_CRYPT=define
CRYPT_FLAG=-DHAVE_DES_FCRYPT
.ENDIF
+BUILDOPT *= $(USE_THREADS)
+#BUILDOPT *= $(USE_THREADS) -DMULTIPLICITY
+#BUILDOPT *= $(USE_THREADS) -DPERL_GLOBAL_STRUCT -DMULTIPLICITY
+# -DUSE_PERLIO -D__STDC__=1 -DUSE_SFIO -DI_SFIO -I\sfio97\include
+
+.IMPORT .IGNORE : PROCESSOR_ARCHITECTURE
+
+PROCESSOR_ARCHITECTURE *= x86
+
+.IF "$(USE_THREADS)" == ""
+ARCHNAME = MSWin32-$(PROCESSOR_ARCHITECTURE)
+.ELSE
+ARCHNAME = MSWin32-$(PROCESSOR_ARCHITECTURE)-thread
+.ENDIF
+
+ARCHDIR = ..\lib\$(ARCHNAME)
+COREDIR = ..\lib\CORE
+
#
# Programs to compile, build .lib files and link
#
@@ -189,10 +202,6 @@ OPTIMIZE = -Od $(RUNTIME) -DNDEBUG
LINK_DBG = -release
.ENDIF
-.IMPORT .IGNORE : PROCESSOR_ARCHITECTURE
-
-PROCESSOR_ARCHITECTURE *= x86
-
# we don't add LIBC here, the compiler do it based on -MD/-MT
LIBFILES = $(CRYPT_LIB) oldnames.lib kernel32.lib user32.lib gdi32.lib \
winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib \
@@ -218,7 +227,10 @@ o *= .obj
.SUFFIXES : .c $(o) .dll .lib .exe .a
.c$(o):
- $(CC) -c $(CFLAGS) $(OBJOUT_FLAG)$@ $<
+ $(CC) -c -I$(<:d) $(CFLAGS) $(OBJOUT_FLAG)$@ $<
+
+.y.c:
+ $(NOOP)
$(o).dll:
.IF "$(CCTYPE)" == "BORLAND"
@@ -251,6 +263,7 @@ PERLEXE=..\perl.exe
GLOBEXE=..\perlglob.exe
CONFIGPM=..\lib\Config.pm
MINIMOD=..\lib\ExtUtils\Miniperl.pm
+X2P=..\x2p\a2p.exe
PL2BAT=bin\pl2bat.pl
GLOBBAT = bin\perlglob.bat
@@ -276,6 +289,7 @@ PERL95EXE=..\perl95.exe
XCOPY=xcopy /f /r /i /d
RCOPY=xcopy /f /r /i /e /d
+NOOP=@echo
#NULL=
.IF "$(CRYPT_SRC)" != ""
@@ -361,6 +375,12 @@ PERL95_OBJ = perl95$(o) \
DLL_OBJ = perllib$(o) $(DYNALOADER)$(o)
+X2P_OBJ = ..\x2p\a2p$(o) \
+ ..\x2p\hash$(o) \
+ ..\x2p\str$(o) \
+ ..\x2p\util$(o) \
+ ..\x2p\walk$(o)
+
CORE_H = ..\av.h \
..\cop.h \
..\cv.h \
@@ -437,7 +457,8 @@ POD2TEXT=$(PODDIR)\pod2text
# Top targets
#
-all: $(PERLEXE) $(PERL95EXE) $(GLOBEXE) $(DYNALOADMODULES) $(MINIMOD) $(GLOBBAT)
+all: $(PERLEXE) $(PERL95EXE) $(GLOBEXE) $(DYNALOADMODULES) $(MINIMOD) \
+ $(X2P)
$(DYNALOADER)$(o) : $(DYNALOADER).c $(CORE_H) $(EXTDIR)\DynaLoader\dlutils.c
@@ -455,9 +476,6 @@ $(GLOBEXE): perlglob$(o)
perlglob$(o) setargv$(o)
.ENDIF
-$(GLOBBAT) : ..\lib\File\DosGlob.pm $(MINIPERL)
- $(MINIPERL) $(PL2BAT) - < ..\lib\File\DosGlob.pm > $(GLOBBAT)
-
perlglob$(o) : perlglob.c
..\miniperlmain$(o) : ..\miniperlmain.c $(CORE_H)
@@ -473,6 +491,7 @@ config.w32 : $(CFGSH_TMPL)
$(MINIPERL) -I..\lib config_sh.PL \
"INST_DRV=$(INST_DRV)" \
"INST_TOP=$(INST_TOP)" \
+ "archname=$(ARCHNAME)" \
"cc=$(CC)" \
"ccflags=$(OPTIMIZE) $(DEFINES)" \
"cf_email=$(EMAIL)" \
@@ -490,9 +509,9 @@ config.w32 : $(CFGSH_TMPL)
$(CONFIGPM) : $(MINIPERL) ..\config.sh config_h.PL ..\minimod.pl
cd .. && miniperl configpm
if exist lib\* $(RCOPY) lib\*.* ..\lib\$(NULL)
- $(XCOPY) ..\*.h ..\lib\CORE\*.*
- $(XCOPY) *.h ..\lib\CORE\*.*
- $(RCOPY) include ..\lib\CORE\*.*
+ $(XCOPY) ..\*.h $(COREDIR)\*.*
+ $(XCOPY) *.h $(COREDIR)\*.*
+ $(RCOPY) include $(COREDIR)\*.*
$(MINIPERL) -I..\lib config_h.PL || $(MAKE) CCTYPE=$(CCTYPE) \
CFG=$(CFG) $(CONFIGPM)
@@ -503,7 +522,7 @@ $(MINIPERL) : ..\miniperlmain$(o) $(CORE_OBJ) $(WIN32_OBJ)
.IF "$(CCTYPE)" == "BORLAND"
$(LINK32) -Tpe -ap $(LINK_FLAGS) \
@$(mktmp c0x32$(o) ..\miniperlmain$(o) \
- $(CORE_OBJ:s,\,\\) $(WIN32_OBJ:s,\,\\),$@,,$(LIBFILES),)
+ $(CORE_OBJ:s,\,\\) $(WIN32_OBJ:s,\,\\),$(@:s,\,\\),,$(LIBFILES),)
.ELIF "$(CCTYPE)" == "GCC"
$(LINK32) -v -o $@ $(LINK_FLAGS) \
$(mktmp $(LKPRE) ..\miniperlmain$(o) \
@@ -517,6 +536,7 @@ $(MINIPERL) : ..\miniperlmain$(o) $(CORE_OBJ) $(WIN32_OBJ)
$(WIN32_OBJ) : $(CORE_H)
$(CORE_OBJ) : $(CORE_H)
$(DLL_OBJ) : $(CORE_H)
+$(X2P_OBJ) : $(CORE_H)
perldll.def : $(MINIPERL) $(CONFIGPM) ..\global.sym makedef.pl
$(MINIPERL) -w makedef.pl $(OPTIMIZE) $(DEFINES) \
@@ -548,7 +568,7 @@ $(PERLDLL): perldll.def $(CORE_OBJ) $(WIN32_OBJ) $(DLL_OBJ)
@$(mktmp $(LINK_FLAGS) $(LIBFILES) $(CORE_OBJ:s,\,\\) \
$(WIN32_OBJ:s,\,\\) $(DLL_OBJ:s,\,\\))
.ENDIF
- $(XCOPY) $(PERLIMPLIB) ..\lib\CORE
+ $(XCOPY) $(PERLIMPLIB) $(COREDIR)
perl.def : $(MINIPERL) makeperldef.pl
$(MINIPERL) -I..\lib makeperldef.pl $(NULL) > perl.def
@@ -556,6 +576,20 @@ perl.def : $(MINIPERL) makeperldef.pl
$(MINIMOD) : $(MINIPERL) ..\minimod.pl
cd .. && miniperl minimod.pl > lib\ExtUtils\Miniperl.pm
+$(X2P) : $(X2P_OBJ)
+ $(MINIPERL) ..\x2p\find2perl.PL
+ $(MINIPERL) ..\x2p\s2p.PL
+.IF "$(CCTYPE)" == "BORLAND"
+ $(LINK32) -Tpe -ap $(LINK_FLAGS) \
+ @$(mktmp c0x32$(o) $(X2P_OBJ:s,\,\\),$(@:s,\,\\),,$(LIBFILES),)
+.ELIF "$(CCTYPE)" == "GCC"
+ $(LINK32) -v -o $@ $(LINK_FLAGS) \
+ $(mktmp $(LKPRE) $(X2P_OBJ:s,\,\\) $(LIBFILES) $(LKPOST))
+.ELSE
+ $(LINK32) -subsystem:console -out:$@ \
+ @$(mktmp $(LINK_FLAGS) $(LIBFILES) $(X2P_OBJ:s,\,\\)
+.ENDIF
+
perlmain.c : runperl.c
copy runperl.c perlmain.c
@@ -649,7 +683,7 @@ doc: $(PERLEXE)
pod2html pod2latex pod2man pod2text
cd ..\pod && $(XCOPY) *.bat ..\win32\bin\*.*
copy ..\README.win32 ..\pod\perlwin32.pod
- $(PERLEXE) ..\installhtml --podroot=.. --htmldir=./html \
+ $(PERLEXE) -I..\lib ..\installhtml --podroot=.. --htmldir=./html \
--podpath=pod:lib:ext:utils --htmlroot="//$(INST_HTML:s,:,|,)" \
--libpod=perlfunc:perlguts:perlvar:perlrun:perlop --recurse
@@ -658,8 +692,8 @@ utils: $(PERLEXE)
cd ..\utils && $(PERLEXE) ..\win32\$(PL2BAT) h2ph splain perlbug \
pl2pm c2ph h2xs perldoc pstruct
$(XCOPY) ..\utils\*.bat bin\*.*
- $(PERLEXE) $(PL2BAT) bin\network.pl bin\www.pl bin\runperl.pl \
- bin\pl2bat.pl
+ $(PERLEXE) -I..\lib $(PL2BAT) bin\network.pl bin\www.pl bin\runperl.pl \
+ bin\pl2bat.pl bin\perlglob.pl
distclean: clean
-del /f $(MINIPERL) $(PERLEXE) $(PERL95EXE) $(PERLDLL) $(GLOBEXE) \
@@ -677,22 +711,17 @@ distclean: clean
.ENDIF
-del /f bin\*.bat
-cd $(EXTDIR) && del /s *.lib *.def *.map *.bs Makefile *$(o) pm_to_blib
- -rmdir /s /q ..\lib\auto
- -rmdir /s /q ..\lib\CORE
+ -rmdir /s /q ..\lib\auto || rmdir /s ..\lib\auto
+ -rmdir /s /q $(COREDIR) || rmdir /s $(COREDIR)
install : all doc utils
- if not exist $(INST_TOP) mkdir $(INST_TOP)
- echo I $(INST_TOP) L $(LIBDIR)
- $(XCOPY) $(PERLEXE) $(INST_BIN)\*.*
+ $(PERLEXE) ..\installperl
.IF "$(PERL95EXE)" != ""
$(XCOPY) $(PERL95EXE) $(INST_BIN)\*.*
.ENDIF
$(XCOPY) $(GLOBEXE) $(INST_BIN)\*.*
- $(XCOPY) $(PERLDLL) $(INST_BIN)\*.*
$(XCOPY) bin\*.bat $(INST_BIN)\*.*
- $(RCOPY) ..\lib $(INST_LIB)\*.*
$(XCOPY) ..\pod\*.bat $(INST_BIN)\*.*
- $(XCOPY) ..\pod\*.pod $(INST_POD)\*.*
$(RCOPY) html\*.* $(INST_HTML)\*.*
inst_lib : $(CONFIGPM)
@@ -700,7 +729,7 @@ inst_lib : $(CONFIGPM)
$(MINIPERL) -I..\lib ..\splittree.pl "../LIB" "../LIB/auto"
$(RCOPY) ..\lib $(INST_LIB)\*.*
-minitest : $(MINIPERL) $(GLOBEXE) $(CONFIGPM)
+minitest : $(MINIPERL) $(GLOBEXE) $(CONFIGPM) utils
$(XCOPY) $(MINIPERL) ..\t\perl.exe
.IF "$(CCTYPE)" == "BORLAND"
$(XCOPY) $(GLOBBAT) ..\t\$(NULL)
@@ -712,7 +741,7 @@ minitest : $(MINIPERL) $(GLOBEXE) $(CONFIGPM)
cd ..\t && \
$(MINIPERL) -I..\lib test base/*.t comp/*.t cmd/*.t io/*.t op/*.t pragma/*.t
-test-prep : all
+test-prep : all utils
$(XCOPY) $(PERLEXE) ..\t\$(NULL)
$(XCOPY) $(PERLDLL) ..\t\$(NULL)
.IF "$(CCTYPE)" == "BORLAND"
@@ -741,8 +770,10 @@ clean :
-@erase $(CORE_OBJ)
-@erase $(WIN32_OBJ)
-@erase $(DLL_OBJ)
+ -@erase $(X2P_OBJ)
-@erase ..\*$(o) ..\*.lib ..\*.exp *$(o) *.lib *.exp
-@erase ..\t\*.exe ..\t\*.dll ..\t\*.bat
+ -@erase ..\x2p\*.exe ..\x2p\*.bat
-@erase *.ilk
-@erase *.pdb
diff --git a/win32/win32.h b/win32/win32.h
index 5a7c89bf97..8d6b04197d 100644
--- a/win32/win32.h
+++ b/win32/win32.h
@@ -109,15 +109,15 @@ struct tms {
#define DllMain DllEntryPoint
#endif
-#pragma warn -ccc
-#pragma warn -rch
-#pragma warn -sig
-#pragma warn -pia
-#pragma warn -par
-#pragma warn -aus
-#pragma warn -use
-#pragma warn -csu
-#pragma warn -pro
+#pragma warn -ccc /* "condition is always true/false" */
+#pragma warn -rch /* "unreachable code" */
+#pragma warn -sig /* "conversion may lose significant digits" */
+#pragma warn -pia /* "possibly incorrect assignment" */
+#pragma warn -par /* "parameter 'foo' is never used" */
+#pragma warn -aus /* "'foo' is assigned a value that is never used" */
+#pragma warn -use /* "'foo' is declared but never used" */
+#pragma warn -csu /* "comparing signed and unsigned values" */
+#pragma warn -pro /* "call to function with no prototype" */
#endif
diff --git a/x2p/a2p.h b/x2p/a2p.h
index 085935d98f..a7cbcb68b3 100644
--- a/x2p/a2p.h
+++ b/x2p/a2p.h
@@ -9,12 +9,37 @@
*/
#define VOIDUSED 1
+
+#ifdef WIN32
+#define _INC_WIN32_PERL5 /* kludge around win32 stdio layer */
+#endif
+
#ifdef VMS
# include "config.h"
#else
# include "../config.h"
#endif
+#ifdef WIN32
+#undef USE_STDIO_PTR /* XXX fast gets won't work, must investigate */
+# ifndef STANDARD_C
+# define STANDARD_C
+# endif
+# if defined(__BORLANDC__)
+# pragma warn -ccc
+# pragma warn -rch
+# pragma warn -sig
+# pragma warn -pia
+# pragma warn -par
+# pragma warn -aus
+# pragma warn -use
+# pragma warn -csu
+# pragma warn -pro
+# elif defined(_MSC_VER)
+# elif defined(__MINGW32__)
+# endif
+#endif
+
#if defined(__STDC__) || defined(vax11c) || defined(_AIX) || defined(__stdc__) || defined(__cplusplus)
# define STANDARD_C 1
#endif
diff --git a/x2p/a2py.c b/x2p/a2py.c
index 202d5921e0..fefa81da7e 100644
--- a/x2p/a2py.c
+++ b/x2p/a2py.c
@@ -8,7 +8,7 @@
* $Log: a2py.c,v $
*/
-#ifdef OS2
+#if defined(OS2) || defined(WIN32)
#include "../patchlevel.h"
#endif
#include "util.h"
@@ -26,7 +26,9 @@ int oper4(int type, int arg1, int arg2, int arg3, int arg4);
int oper5(int type, int arg1, int arg2, int arg3, int arg4, int arg5);
STR *walk(int useval, int level, register int node, int *numericptr, int minprec);
-#ifdef OS2
+#if defined(OS2) || defined(WIN32)
+static void usage(void);
+
static void
usage()
{
@@ -86,9 +88,11 @@ main(register int argc, register char **argv, register char **env)
case 0:
break;
default:
- fatal("Unrecognized switch: %s\n",argv[0]);
-#ifdef OS2
+#if defined(OS2) || defined(WIN32)
+ fprintf(stderr, "Unrecognized switch: %s\n",argv[0]);
usage();
+#else
+ fatal("Unrecognized switch: %s\n",argv[0]);
#endif
}
}
@@ -97,7 +101,7 @@ main(register int argc, register char **argv, register char **env)
/* open script */
if (argv[0] == Nullch) {
-#ifdef OS2
+#if defined(OS2) || defined(WIN32)
if ( isatty(fileno(stdin)) )
usage();
#endif
View Lorry Controller Status