Change 18304: Redone #18011 from metaunits
Change 18304 by merijn@merijn-l1 on 2002/12/16 10:44:57 Redone #18011 from metaunits Affected files ... ... //depot/perl/Configure#494 edit Differences ... //depot/perl/Configure#494 (xtext) Index: perl/Configure --- perl/Configure#493~18182~ Tue Nov 26 00:44:39 2002 +++ perl/Configure Mon Dec 16 02:44:57 2002 @@ -20,7 +20,7 @@ # $Id: Head.U,v 3.0.1.9 1997/02/28 15:02:09 ram Exp $ # -# Generated on Tue Nov 26 10:51:37 MET 2002 [metaconfig 3.0 PL70] +# Generated on Mon Dec 16 12:51:57 MET 2002 [metaconfig 3.0 PL70] # (with additional metaconfig patches by [EMAIL PROTECTED]) cat >c1$$ <
Change 18305: Enough changes to Configure and metaunits warrant an update.
Change 18305 by merijn@merijn-l1 on 2002/12/16 10:53:19 Enough changes to Configure and metaunits warrant an update. Several small changes and three additions Affected files ... ... //depot/perl/Porting/Glossary#140 edit Differences ... //depot/perl/Porting/Glossary#140 (text) Index: perl/Porting/Glossary --- perl/Porting/Glossary#139~18030~Sat Oct 19 07:10:21 2002 +++ perl/Porting/Glossary Mon Dec 16 02:53:19 2002 @@ -1399,6 +1399,10 @@ of the source want to take special action if MYMALLOC is used. This may include different sorts of profiling or error detection. +d_nanosleep (d_nanosleep.U): + This variable conditionally defines HAS_NANOSLEEP + if nanosleep() is available to sleep with 1E-9 sec accuracy. + d_nice (d_nice.U): This variable conditionally defines the HAS_NICE symbol, which indicates to the C program that the nice() routine is available. @@ -2408,13 +2412,18 @@ can share this executable will have the same full pathname to 'sed.' +gccansipedantic (gccvers.U): + If GNU cc (gcc) is used, this variable will enable (if set) the + -ansi and -pedantic ccflags for building core files (through + cflags script). (See Porting/pumpkin.pod for full description). + gccosandvers (gccvers.U): - If GNU cc (gcc) is used, this variable the operating system and - version used to compile the gcc. It is set to '' if not gcc, + If GNU cc (gcc) is used, this variable holds the operating system + and version used to compile gcc. It is set to '' if not gcc, or if nothing useful can be parsed as the os version. gccversion (gccvers.U): - If GNU cc (gcc) is used, this variable holds '1' or '2' to + If GNU cc (gcc) is used, this variable holds '1' or '2' to indicate whether the compiler is version 1 or 2. This is used in setting some of the default cflags. It is set to '' if not gcc. @@ -3094,6 +3103,22 @@ is useful if $prefix is shared by many packages, e.g. if $prefix=/usr/local. + Unfortunately, while this "style" variable is used to set + defaults for all three directory hierarchies (core, vendor, and + site), there is no guarantee that the same style is actually + appropriate for all those directories. For example, $prefix + might be /opt/perl, but $siteprefix might be /usr/local. + (Perhaps, in retrospect, the "lib" style should never have been + supported, but it did seem like a nice idea at the time.) + + The situation is even less clear for tools such as MakeMaker + that can be used to install additional modules into + non-standard places. For example, if a user intends to install + a module into a private directory (perhaps by setting PREFIX on + the Makefile.PL command line), then there is no reason to + assume that the Configure-time $installstyle setting will be + relevant for that PREFIX. + This may later be extended to include other information, so be careful with pattern-matching on the results. @@ -4113,7 +4138,7 @@ spitshell (spitshell.U): This variable contains the command necessary to spit out a runnable - shell on this system. It is either cat or a grep '-v' for # comments. + shell on this system. It is either cat or a grep -v for # comments. srand48_r_proto (d_srand48_r.U): This variable encodes the prototype of srand48_r. End of Patch.
Change 18306: More documentation of obscure flags is good, even if the
Change 18306 by sky@sky-tibook on 2002/12/16 21:41:40 More documentation of obscure flags is good, even if the documentation might be not so good. Atleast it's not false! Documents the flags one can give to perl_clone Affected files ... ... //depot/perl/sv.c#604 edit Differences ... //depot/perl/sv.c#604 (text) Index: perl/sv.c --- perl/sv.c#603~18302~Sat Dec 14 14:34:25 2002 +++ perl/sv.c Mon Dec 16 13:41:40 2002 @@ -10046,6 +10046,35 @@ Create and return a new interpreter by cloning the current one. +perl_clone takes these flags as paramters: + +CLONEf_COPY_STACKS - is used to, well, copy the stacks also, +without it we only clone the data and zero the stacks, +with it we copy the stacks and the new perl interpreter is +ready to run at the exact same point as the previous one. +The pseudo-fork code uses COPY_STACKS while the +threads->new doesn't. + +CLONEf_KEEP_PTR_TABLE +perl_clone keeps a ptr_table with the pointer of the old +variable as a key and the new variable as a value, +this allows it to check if something has been cloned and not +clone it again but rather just use the value and increase the +refcount. If KEEP_PTR_TABLE is not set then perl_clone will kill +the ptr_table using the function +C, +reason to keep it around is if you want to dup some of your own +variable who are outside the graph perl scans, example of this +code is in threads.xs create + +CLONEf_CLONE_HOST +This is a win32 thing, it is ignored on unix, it tells perls +win32host code (which is c++) to clone itself, this is needed on +win32 if you want to run two threads at the same time, +if you just want to do some stuff in a separate perl interpreter +and then throw it away and return to the original one, +you don't need to do anything. + =cut */ End of Patch.
Change 18307: [PATCH] Re: [perl #19017] lexical "my" variables not visible in debugger "x" command
Change 18307 by rgs@rgs-home on 2002/12/16 22:01:14
Subject: [PATCH] Re: [perl #19017] lexical "my" variables not visible in
debugger "x" command
From: Dave Mitchell <[EMAIL PROTECTED]>
Date: Thu, 12 Dec 2002 23:42:35 +
Message-ID: <[EMAIL PROTECTED]>
and
Date: Sat, 14 Dec 2002 19:16:38 +
Message-ID: <[EMAIL PROTECTED]>
Affected files ...
... //depot/perl/embed.fnc#58 edit
... //depot/perl/embed.h#373 edit
... //depot/perl/pod/perlfunc.pod#361 edit
... //depot/perl/pod/perlintern.pod#27 edit
... //depot/perl/pp_ctl.c#331 edit
... //depot/perl/proto.h#416 edit
... //depot/perl/t/op/eval.t#24 edit
Differences ...
//depot/perl/embed.fnc#58 (text)
Index: perl/embed.fnc
--- perl/embed.fnc#57~18302~Sat Dec 14 14:34:25 2002
+++ perl/embed.fnc Mon Dec 16 14:01:14 2002
@@ -1353,7 +1353,7 @@
# endif
s |CV*|cv_clone2 |CV *proto|CV *outside
#endif
-pd |CV*|find_runcv
+pd |CV*|find_runcv |U32 *db_seqp
//depot/perl/embed.h#373 (text+w)
Index: perl/embed.h
--- perl/embed.h#372~18220~ Sun Dec 1 16:58:54 2002
+++ perl/embed.hMon Dec 16 14:01:14 2002
@@ -2760,7 +2760,7 @@
# endif
#define cv_clone2(a,b) S_cv_clone2(aTHX_ a,b)
#endif
-#define find_runcv() Perl_find_runcv(aTHX)
+#define find_runcv(a) Perl_find_runcv(aTHX_ a)
#define ck_anoncode(a) Perl_ck_anoncode(aTHX_ a)
#define ck_bitop(a)Perl_ck_bitop(aTHX_ a)
#define ck_concat(a) Perl_ck_concat(aTHX_ a)
//depot/perl/pod/perlfunc.pod#361 (text)
Index: perl/pod/perlfunc.pod
--- perl/pod/perlfunc.pod#360~18115~Wed Nov 6 12:43:14 2002
+++ perl/pod/perlfunc.pod Mon Dec 16 14:01:14 2002
@@ -1449,6 +1449,11 @@
C does I count as a loop, so the loop control statements
C, C, or C cannot be used to leave or restart the block.
+Note that as a very special case, an C executed within the C
+package doesn't see the usual surrounding lexical scope, but rather the
+scope of the first non-DB piece of code that called it. You don't normally
+need to worry about this unless you are writing a Perl debugger.
+
=item exec LIST
=item exec PROGRAM LIST
//depot/perl/pod/perlintern.pod#27 (text+w)
Index: perl/pod/perlintern.pod
--- perl/pod/perlintern.pod#26~18302~ Sat Dec 14 14:34:25 2002
+++ perl/pod/perlintern.pod Mon Dec 16 14:01:14 2002
@@ -285,8 +285,12 @@
=item find_runcv
Locate the CV corresponding to the currently executing sub or eval.
+If db_seqp is non_null, skip CVs that are in the DB package and populate
+*db_seqp with the cop sequence number at the point that the DB:: code was
+entered. (allows debuggers to eval in the scope of the breakpoint rather
+than in in the scope of the debuger itself).
- CV* find_runcv()
+ CV* find_runcv(U32 *db_seqp)
=for hackers
Found in file pp_ctl.c
//depot/perl/pp_ctl.c#331 (text)
Index: perl/pp_ctl.c
--- perl/pp_ctl.c#330~18302~Sat Dec 14 14:34:25 2002
+++ perl/pp_ctl.c Mon Dec 16 14:01:14 2002
@@ -2615,7 +2615,7 @@
/* we get here either during compilation, or via pp_regcomp at runtime */
runtime = PL_op && (PL_op->op_type == OP_REGCOMP);
if (runtime)
- runcv = find_runcv();
+ runcv = find_runcv(NULL);
PL_op = &dummy;
PL_op->op_type = OP_ENTEREVAL;
@@ -2649,22 +2649,35 @@
=for apidoc find_runcv
Locate the CV corresponding to the currently executing sub or eval.
+If db_seqp is non_null, skip CVs that are in the DB package and populate
+*db_seqp with the cop sequence number at the point that the DB:: code was
+entered. (allows debuggers to eval in the scope of the breakpoint rather
+than in in the scope of the debuger itself).
=cut
*/
CV*
-Perl_find_runcv(pTHX)
+Perl_find_runcv(pTHX_ U32 *db_seqp)
{
I32 ix;
PERL_SI *si;
PERL_CONTEXT *cx;
+if (db_seqp)
+ *db_seqp = PL_curcop->cop_seq;
for (si = PL_curstackinfo; si; si = si->si_prev) {
for (ix = si->si_cxix; ix >= 0; ix--) {
cx = &(si->si_cxstack[ix]);
- if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
- return cx->blk_sub.cv;
+ if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
+ CV *cv = cx->blk_sub.cv;
+ /* skip DB:: code */
+ if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
+ *db_seqp = cx->blk_oldcop->cop_seq;
+ continue;
+ }
+ return cv;
+ }
else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
return PL_compcv;
}
@@ -3222,6 +3235,7 @@
STRLEN len;
OP *ret;
CV* runcv;
+U32 seq;
if (!SvPV(sv,len))
RETPUSHUNDEF;
@@ -3269,7 +3283,12 @@
PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
SAVEFREESV(PL_compiling.cop_io);
Change 18308: [PATCH] Re: [perl #19017] lexical "my" variables not visible in debugger "x" command
Change 18308 by rgs@rgs-home on 2002/12/16 22:06:23 Subject: [PATCH] Re: [perl #19017] lexical "my" variables not visible in debugger "x" command From: [EMAIL PROTECTED] (Peter Scott) Date: 12 Dec 2002 18:13:17 - Message-ID: <[EMAIL PROTECTED]> (fix bug [perl #19058]) Affected files ... ... //depot/perl/lib/perl5db.pl#90 edit Differences ... //depot/perl/lib/perl5db.pl#90 (text) Index: perl/lib/perl5db.pl --- perl/lib/perl5db.pl#89~17291~ Tue Jun 18 14:28:33 2002 +++ perl/lib/perl5db.pl Mon Dec 16 14:06:23 2002 @@ -2738,6 +2738,7 @@ B [I [I]]List some (default all) variables in package (default current). Use B<~>I and BI for positive and negative regexps. B [I] Same as \"B I [I]\". +B [I [I]] List lexicals in higher scope . Vars same as B. B I Evals expression in list context, dumps the result. B I Evals expression in list context, prints methods callable on the first element of the result. End of Patch.
Change 18310: regen-headers to get new API docs from #18306
Change 18310 by [EMAIL PROTECTED] on 2002/12/17 00:51:46 regen-headers to get new API docs from #18306 Affected files ... ... //depot/perl/pod/perlapi.pod#146 edit Differences ... //depot/perl/pod/perlapi.pod#146 (text+w) Index: perl/pod/perlapi.pod --- perl/pod/perlapi.pod#145~18302~ Sat Dec 14 14:34:25 2002 +++ perl/pod/perlapi.podMon Dec 16 16:51:46 2002 @@ -512,6 +512,35 @@ Create and return a new interpreter by cloning the current one. +perl_clone takes these flags as paramters: + +CLONEf_COPY_STACKS - is used to, well, copy the stacks also, +without it we only clone the data and zero the stacks, +with it we copy the stacks and the new perl interpreter is +ready to run at the exact same point as the previous one. +The pseudo-fork code uses COPY_STACKS while the +threads->new doesn't. + +CLONEf_KEEP_PTR_TABLE +perl_clone keeps a ptr_table with the pointer of the old +variable as a key and the new variable as a value, +this allows it to check if something has been cloned and not +clone it again but rather just use the value and increase the +refcount. If KEEP_PTR_TABLE is not set then perl_clone will kill +the ptr_table using the function +C, +reason to keep it around is if you want to dup some of your own +variable who are outside the graph perl scans, example of this +code is in threads.xs create + +CLONEf_CLONE_HOST +This is a win32 thing, it is ignored on unix, it tells perls +win32host code (which is c++) to clone itself, this is needed on +win32 if you want to run two threads at the same time, +if you just want to do some stuff in a separate perl interpreter +and then throw it away and return to the original one, +you don't need to do anything. + PerlInterpreter*perl_clone(PerlInterpreter* interp, UV flags) =for hackers End of Patch.
Change 18311: [PATCH] Re: [jhi@iki.fi: enums are not nums]
Change 18311 by [EMAIL PROTECTED] on 2002/12/17 00:52:05
Subject: [PATCH] Re: [[EMAIL PROTECTED]: enums are not nums]
From: Dave Mitchell <[EMAIL PROTECTED]>
Date: Sat, 14 Dec 2002 19:16:49 +
Message-ID: <[EMAIL PROTECTED]>
Affected files ...
... //depot/perl/embed.fnc#59 edit
... //depot/perl/pad.c#8 edit
... //depot/perl/pad.h#5 edit
... //depot/perl/pod/perlintern.pod#28 edit
... //depot/perl/proto.h#417 edit
Differences ...
//depot/perl/embed.fnc#59 (text)
Index: perl/embed.fnc
--- perl/embed.fnc#58~18307~Mon Dec 16 14:01:14 2002
+++ perl/embed.fnc Mon Dec 16 16:52:05 2002
@@ -1328,7 +1328,7 @@
|I32 stack_max|I32 mark_min|I32 mark_max
#endif
-pd |PADLIST*|pad_new |padnew_flags flags
+pd |PADLIST*|pad_new |int flags
pd |void |pad_undef |CV* cv
pd |PADOFFSET|pad_add_name |char *name\
|HV* typestash|HV* ourstash \
//depot/perl/pad.c#8 (text)
Index: perl/pad.c
--- perl/pad.c#7~18302~ Sat Dec 14 14:34:25 2002
+++ perl/pad.c Mon Dec 16 16:52:05 2002
@@ -111,7 +111,7 @@
*/
PADLIST *
-Perl_pad_new(pTHX_ padnew_flags flags)
+Perl_pad_new(pTHX_ int flags)
{
AV *padlist, *padname, *pad, *a0;
//depot/perl/pad.h#5 (text)
Index: perl/pad.h
--- perl/pad.h#4~18142~ Tue Nov 12 14:09:39 2002
+++ perl/pad.h Mon Dec 16 16:52:05 2002
@@ -34,11 +34,9 @@
/* flags for the pad_new() function */
-typedef enum {
- padnew_CLONE= 1,/* this pad is for a cloned CV */
- padnew_SAVE = 2,/* save old globals */
- padnew_SAVESUB = 4 /* also save extra stuff for start of sub */
-} padnew_flags;
+#define padnew_CLONE 1 /* this pad is for a cloned CV */
+#define padnew_SAVE2 /* save old globals */
+#define padnew_SAVESUB 4 /* also save extra stuff for start of sub */
/* values for the pad_tidy() function */
//depot/perl/pod/perlintern.pod#28 (text+w)
Index: perl/pod/perlintern.pod
--- perl/pod/perlintern.pod#27~18307~ Mon Dec 16 14:01:14 2002
+++ perl/pod/perlintern.pod Mon Dec 16 16:52:05 2002
@@ -652,7 +652,7 @@
padnew_SAVEsave old globals
padnew_SAVESUB also save extra stuff for start of sub
- PADLIST*pad_new(padnew_flags flags)
+ PADLIST*pad_new(int flags)
=for hackers
Found in file pad.c
//depot/perl/proto.h#417 (text+w)
Index: perl/proto.h
--- perl/proto.h#416~18307~ Mon Dec 16 14:01:14 2002
+++ perl/proto.hMon Dec 16 16:52:05 2002
@@ -1359,7 +1359,7 @@
STATIC voidS_deb_stack_n(pTHX_ SV** stack_base, I32 stack_min, I32 stack_max, I32
mark_min, I32 mark_max);
#endif
-PERL_CALLCONV PADLIST* Perl_pad_new(pTHX_ padnew_flags flags);
+PERL_CALLCONV PADLIST* Perl_pad_new(pTHX_ int flags);
PERL_CALLCONV void Perl_pad_undef(pTHX_ CV* cv);
PERL_CALLCONV PADOFFSETPerl_pad_add_name(pTHX_ char *name, HV* typestash, HV*
ourstash, bool clone);
PERL_CALLCONV PADOFFSETPerl_pad_add_anon(pTHX_ SV* sv, OPCODE op_type);
End of Patch.
Change 18312: [Fwd: Patch for perl utf8-related bug]
Change 18312 by [EMAIL PROTECTED] on 2002/12/17 01:43:28
Subject: [Fwd: Patch for perl utf8-related bug]
From: Richard Hitt <[EMAIL PROTECTED]>
Date: Fri, 06 Dec 2002 16:47:42 -0800
[perl #18932]
Affected files ...
... //depot/perl/embed.fnc#60 edit
... //depot/perl/embed.h#374 edit
... //depot/perl/global.sym#229 edit
... //depot/perl/perl.h#481 edit
... //depot/perl/proto.h#418 edit
... //depot/perl/regcomp.c#316 edit
... //depot/perl/scope.c#104 edit
... //depot/perl/scope.h#54 edit
Differences ...
//depot/perl/embed.fnc#60 (text)
Index: perl/embed.fnc
--- perl/embed.fnc#59~18311~Mon Dec 16 16:52:05 2002
+++ perl/embed.fnc Mon Dec 16 17:43:28 2002
@@ -626,6 +626,7 @@
Ap |I32|save_alloc |I32 size|I32 pad
Ap |void |save_aptr |AV** aptr
Ap |AV*|save_ary |GV* gv
+Ap |void |save_bool |bool* boolp
Ap |void |save_clearsv |SV** svp
Ap |void |save_delete|HV* hv|char* key|I32 klen
Ap |void |save_destructor|DESTRUCTORFUNC_NOCONTEXT_t f|void* p
//depot/perl/embed.h#374 (text+w)
Index: perl/embed.h
--- perl/embed.h#373~18307~ Mon Dec 16 14:01:14 2002
+++ perl/embed.hMon Dec 16 17:43:28 2002
@@ -564,6 +564,7 @@
#define save_alloc Perl_save_alloc
#define save_aptr Perl_save_aptr
#define save_ary Perl_save_ary
+#define save_bool Perl_save_bool
#define save_clearsv Perl_save_clearsv
#define save_deletePerl_save_delete
#define save_destructorPerl_save_destructor
@@ -2122,6 +2123,7 @@
#define save_alloc(a,b)Perl_save_alloc(aTHX_ a,b)
#define save_aptr(a) Perl_save_aptr(aTHX_ a)
#define save_ary(a)Perl_save_ary(aTHX_ a)
+#define save_bool(a) Perl_save_bool(aTHX_ a)
#define save_clearsv(a)Perl_save_clearsv(aTHX_ a)
#define save_delete(a,b,c) Perl_save_delete(aTHX_ a,b,c)
#define save_destructor(a,b) Perl_save_destructor(aTHX_ a,b)
//depot/perl/global.sym#229 (text+w)
Index: perl/global.sym
--- perl/global.sym#228~18113~ Tue Nov 5 12:11:55 2002
+++ perl/global.sym Mon Dec 16 17:43:28 2002
@@ -376,6 +376,7 @@
Perl_save_alloc
Perl_save_aptr
Perl_save_ary
+Perl_save_bool
Perl_save_clearsv
Perl_save_delete
Perl_save_destructor
//depot/perl/perl.h#481 (text)
Index: perl/perl.h
--- perl/perl.h#480~18217~ Fri Nov 29 04:11:28 2002
+++ perl/perl.h Mon Dec 16 17:43:28 2002
@@ -2173,6 +2173,7 @@
I32any_i32;
IV any_iv;
long any_long;
+bool any_bool;
void (*any_dptr) (void*);
void (*any_dxptr) (pTHX_ void*);
};
//depot/perl/proto.h#418 (text+w)
Index: perl/proto.h
--- perl/proto.h#417~18311~ Mon Dec 16 16:52:05 2002
+++ perl/proto.hMon Dec 16 17:43:28 2002
@@ -661,6 +661,7 @@
PERL_CALLCONV I32 Perl_save_alloc(pTHX_ I32 size, I32 pad);
PERL_CALLCONV void Perl_save_aptr(pTHX_ AV** aptr);
PERL_CALLCONV AV* Perl_save_ary(pTHX_ GV* gv);
+PERL_CALLCONV void Perl_save_bool(pTHX_ bool* boolp);
PERL_CALLCONV void Perl_save_clearsv(pTHX_ SV** svp);
PERL_CALLCONV void Perl_save_delete(pTHX_ HV* hv, char* key, I32 klen);
PERL_CALLCONV void Perl_save_destructor(pTHX_ DESTRUCTORFUNC_NOCONTEXT_t f, void*
p);
//depot/perl/regcomp.c#316 (text)
Index: perl/regcomp.c
--- perl/regcomp.c#315~18268~ Sun Dec 8 16:14:58 2002
+++ perl/regcomp.c Mon Dec 16 17:43:28 2002
@@ -5058,7 +5058,7 @@
SAVEVPTR(PL_reg_re); /* from regexec.c */
SAVEPPTR(PL_reg_ganch);/* from regexec.c */
SAVESPTR(PL_reg_sv); /* from regexec.c */
-SAVEI8(PL_reg_match_utf8); /* from regexec.c */
+SAVEBOOL(PL_reg_match_utf8); /* from regexec.c */
SAVEVPTR(PL_reg_magic);/* from regexec.c */
SAVEI32(PL_reg_oldpos);/* from regexec.c */
SAVEVPTR(PL_reg_oldcurpm); /* from regexec.c */
//depot/perl/scope.c#104 (text)
Index: perl/scope.c
--- perl/scope.c#103~18048~ Tue Oct 22 10:04:26 2002
+++ perl/scope.cMon Dec 16 17:43:28 2002
@@ -391,6 +391,15 @@
}
void
+Perl_save_bool(pTHX_ bool *boolp)
+{
+SSCHECK(3);
+SSPUSHBOOL(*boolp);
+SSPUSHPTR(boolp);
+SSPUSHINT(SAVEt_BOOL);
+}
+
+void
Perl_save_I32(pTHX_ I32 *intp)
{
SSCHECK(3);
@@ -788,6 +797,10 @@
case SAVEt_LONG:/* long reference */
ptr = SSPOPPTR;
*(long*)ptr = (long)SSPOPLONG;
+ break;
+ case SAVEt_BOOL:/* bool reference */
+ ptr = SSPOPPTR;
+ *(bool*)ptr = (bool)SSPOPBOOL;
break;
case SAVEt_I32: /* I32 reference */
ptr = SSPOPPTR;
//depot/perl/scope.h#54 (text)
Index: perl/sco
Change 18314: [PATCH 5.8.1 @oldish-18156] Morphing to PM on OS/2
Change 18314 by [EMAIL PROTECTED] on 2002/12/17 01:58:32
Subject: [PATCH 5.8.1 @oldish-18156] Morphing to PM on OS/2
From: Ilya Zakharevich <[EMAIL PROTECTED]>
Date: Fri, 13 Dec 2002 14:00:48 -0800
Message-ID: <[EMAIL PROTECTED]>
Affected files ...
... //depot/perl/os2/OS2/Process/t/os2_process.t#2 edit
... //depot/perl/os2/os2.c#63 edit
Differences ...
//depot/perl/os2/OS2/Process/t/os2_process.t#2 (text)
Index: perl/os2/OS2/Process/t/os2_process.t
--- perl/os2/OS2/Process/t/os2_process.t#1~14705~ Fri Feb 15 00:42:55 2002
+++ perl/os2/OS2/Process/t/os2_process.tMon Dec 16 17:58:32 2002
@@ -24,7 +24,7 @@
}
use strict;
-use Test::More tests => 227;
+use Test::More tests => 230;
use OS2::Process;
sub SWP_flags ($) {
@@ -237,21 +237,25 @@
# This does not work, the result is the handle of "Window List"
# is((hWindowPos $k_hwnd)->{behind}, 4, 'kis is at back');
-my (@list, $next);
+my (@list, $next, @list1);
{ my $force_PM = OS2::localMorphPM->new(0);
ok $force_PM, 'morphed to PM locally again';
$enum_handle = BeginEnumWindows 1; # HWND_DESKTOP
ok $enum_handle, 'start enumeration';
push @list, $next while $next = GetNextWindow $enum_handle;
+ @list1 = ChildWindows;
+ ok 1, 'embedded ChildWindows()';
ok EndEnumWindows($enum_handle), 'end enumeration';
+ is_deeply \@list, \@list1, 'Manual list same as by ChildWindows()';
# Apparently, the 'Desktop' window is still behind us;
# Note that this window is *not* what is returned by DesktopWindow
pop @list if WindowText($list[-1]) eq 'Desktop';
}
is ($list[-1], $k_hwnd, 'kid is the last in z-order enumeration');
# print "# kid=$k_hwnd in @list\n";
-@list = ChildWindows; # HWND_DESKTOP
+@list = ChildWindows;
+is_deeply \@list, \@list1, 'Other ChildWindows(), same result';
ok scalar @list, 'ChildWindows works';
is $list[-2], $k_hwnd, 'kid is the last but one in ChildWindows';
//depot/perl/os2/os2.c#63 (text)
Index: perl/os2/os2.c
--- perl/os2/os2.c#62~18030~Sat Oct 19 07:10:21 2002
+++ perl/os2/os2.c Mon Dec 16 17:58:32 2002
@@ -1429,11 +1429,10 @@
HMQ
Perl_Register_MQ(int serve)
{
+ if (Perl_hmq_refcnt <= 0) {
PPIB pib;
PTIB tib;
-if (Perl_hmq_refcnt > 0)
- return Perl_hmq;
Perl_hmq_refcnt = 0; /* Be extra safe */
DosGetInfoBlocks(&tib, &pib);
Perl_os2_initial_mode = pib->pib_ultype;
@@ -1451,6 +1450,7 @@
_exit(188); /* Panic can try to create a window. */
Perl_croak_nocontext("Cannot create a message queue, or morph to a PM
application");
}
+ }
if (serve) {
if ( Perl_hmq_servers <= 0 /* Safe to inform us on shutdown, */
&& Perl_hmq_refcnt > 0 ) /* this was switched off before... */
End of Patch.
Change 18313: [PATCH 5.8.1 @oldish-18156] OS/2 REXX interface assuming Object REXX
Change 18313 by [EMAIL PROTECTED] on 2002/12/17 01:54:19
Subject: [PATCH 5.8.1 @oldish-18156] OS/2 REXX interface assuming Object REXX
From: Ilya Zakharevich <[EMAIL PROTECTED]>
Date: Fri, 13 Dec 2002 14:08:00 -0800
Message-ID: <[EMAIL PROTECTED]>
Affected files ...
... //depot/perl/os2/OS2/REXX/REXX.xs#16 edit
Differences ...
//depot/perl/os2/OS2/REXX/REXX.xs#16 (text)
Index: perl/os2/OS2/REXX/REXX.xs
--- perl/os2/OS2/REXX/REXX.xs#15~13183~ Wed Nov 21 14:33:20 2001
+++ perl/os2/OS2/REXX/REXX.xs Mon Dec 16 17:54:19 2002
@@ -72,7 +72,8 @@
LONG rc;
SV *res;
char *subs = 0;
-int n = c;
+int n = c, have_nl = 0;
+char *ocmd = cmd, *s, *t;
incompartment++;
@@ -84,6 +85,23 @@
subs[n] = 1;
}
+s = cmd;
+while (*s) {
+ if (*s == '\n') { /* Is not preceeded by \r! */
+ New(728, cmd, 2*strlen(cmd)+1, char);
+ s = ocmd;
+ t = cmd;
+ while (*s) {
+ if (*s == '\n')
+ *t++ = '\r';
+ *t++ = *s++;
+ }
+ *t = 0;
+ break;
+ } else if (*s == '\r')
+ s++;
+ s++;
+}
MAKERXSTRING(args[0], NULL, 0);
MAKERXSTRING(inst[0], cmd, strlen(cmd));
MAKERXSTRING(inst[1], NULL, 0);
@@ -105,6 +123,8 @@
pRexxDeregisterFunction(handlerNames[n]);
if (c)
Safefree(subs);
+if (cmd != ocmd)
+ Safefree(cmd);
#if 0 /* Do we want to restore these? */
DosFreeModule(hRexxAPI);
DosFreeModule(hRexx);
End of Patch.
Change 18315: [PATCH 5.8.1 @oldish-18156] deprecated warnings
Change 18315 by [EMAIL PROTECTED] on 2002/12/17 02:03:58
Subject: [PATCH 5.8.1 @oldish-18156] deprecated warnings
From: Ilya Zakharevich <[EMAIL PROTECTED]>
Date: Fri, 13 Dec 2002 13:47:08 -0800
Message-ID: <[EMAIL PROTECTED]>
Affected files ...
... //depot/perl/lib/constant.t#4 edit
... //depot/perl/lib/fields.t#4 edit
Differences ...
//depot/perl/lib/constant.t#4 (text)
Index: perl/lib/constant.t
--- perl/lib/constant.t#3~17730~Sat Aug 17 18:41:33 2002
+++ perl/lib/constant.t Mon Dec 16 18:03:58 2002
@@ -10,7 +10,7 @@
BEGIN {# ...and save 'em for later
$SIG{'__WARN__'} = sub { push @warnings, @_ }
}
-END { print @warnings }
+END { print STDERR @warnings }
use strict;
//depot/perl/lib/fields.t#4 (xtext)
Index: perl/lib/fields.t
--- perl/lib/fields.t#3~17725~ Fri Aug 16 17:51:19 2002
+++ perl/lib/fields.t Mon Dec 16 18:03:58 2002
@@ -10,7 +10,7 @@
$w++;
return;
}
- print $_[0];
+ print STDERR $_[0];
};
}
End of Patch.
Change 18316: [PATCH 5.8.1 @oldish-18156] build
Change 18316 by [EMAIL PROTECTED] on 2002/12/17 02:17:16
Subject: [PATCH 5.8.1 @oldish-18156] build
From: Ilya Zakharevich <[EMAIL PROTECTED]>
Date: Fri, 13 Dec 2002 13:54:05 -0800
Message-ID: <[EMAIL PROTECTED]>
Affected files ...
... //depot/perl/os2/os2.c#64 edit
... //depot/perl/t/run/runenv.t#8 edit
Differences ...
//depot/perl/os2/os2.c#64 (text)
Index: perl/os2/os2.c
--- perl/os2/os2.c#63~18314~Mon Dec 16 17:58:32 2002
+++ perl/os2/os2.c Mon Dec 16 18:17:16 2002
@@ -2637,18 +2637,30 @@
#undef rmdir
+/* EMX flavors do not tolerate trailing slashes. t/op/mkdir.t has many
+ trailing slashes, so we need to support this as well. */
+
int
my_rmdir (__const__ char *s)
{
-char buf[MAXPATHLEN];
+char b[MAXPATHLEN];
+char *buf = b;
STRLEN l = strlen(s);
+int rc;
-if (s[l-1] == '/' || s[l-1] == '\\') { /* EMX rmdir fails... */
+if (s[l-1] == '/' || s[l-1] == '\\') { /* EMX mkdir fails... */
+ if (l >= sizeof b)
+ New(1305, buf, l + 1, char);
strcpy(buf,s);
- buf[l - 1] = 0;
+ while (l > 1 && (s[l-1] == '/' || s[l-1] == '\\'))
+ l--;
+ buf[l] = 0;
s = buf;
}
-return rmdir(s);
+rc = rmdir(s);
+if (b != buf)
+ Safefree(buf);
+return rc;
}
#undef mkdir
@@ -2656,15 +2668,24 @@
int
my_mkdir (__const__ char *s, long perm)
{
-char buf[MAXPATHLEN];
+char b[MAXPATHLEN];
+char *buf = b;
STRLEN l = strlen(s);
+int rc;
if (s[l-1] == '/' || s[l-1] == '\\') { /* EMX mkdir fails... */
+ if (l >= sizeof b)
+ New(1305, buf, l + 1, char);
strcpy(buf,s);
- buf[l - 1] = 0;
+ while (l > 1 && (s[l-1] == '/' || s[l-1] == '\\'))
+ l--;
+ buf[l] = 0;
s = buf;
}
-return mkdir(s, perm);
+rc = mkdir(s, perm);
+if (b != buf)
+ Safefree(buf);
+return rc;
}
#undef flock
//depot/perl/t/run/runenv.t#8 (text)
Index: perl/t/run/runenv.t
--- perl/t/run/runenv.t#7~18136~Sun Nov 10 13:38:44 2002
+++ perl/t/run/runenv.t Mon Dec 16 18:17:16 2002
@@ -39,6 +39,10 @@
$stdout = '' unless defined $stdout;
$stderr = '' unless defined $stderr;
+ local %ENV = %ENV;
+ delete $ENV{PERLLIB};
+ delete $ENV{PERL5LIB};
+ delete $ENV{PERL5OPT};
my $pid = fork;
return (0, "Couldn't fork: $!") unless defined $pid; # failure
if ($pid) { # parent
@@ -149,22 +153,22 @@
'1',
'');
-try({PERLLIB => "foobar:42"},
+try({PERLLIB => "foobar$Config{path_sep}42"},
['-e', 'print grep { $_ eq "foobar" } @INC'],
'foobar',
'');
-try({PERLLIB => "foobar:42"},
+try({PERLLIB => "foobar$Config{path_sep}42"},
['-e', 'print grep { $_ eq "42" } @INC'],
'42',
'');
-try({PERL5LIB => "foobar:42"},
+try({PERL5LIB => "foobar$Config{path_sep}42"},
['-e', 'print grep { $_ eq "foobar" } @INC'],
'foobar',
'');
-try({PERL5LIB => "foobar:42"},
+try({PERL5LIB => "foobar$Config{path_sep}42"},
['-e', 'print grep { $_ eq "42" } @INC'],
'42',
'');
End of Patch.
Change 18317: Integrate Net::Ping v2.26. (lib/Net/Ping/t/450_service.t should work now)
Change 18317 by [EMAIL PROTECTED] on 2002/12/17 02:58:12
Integrate Net::Ping v2.26. (lib/Net/Ping/t/450_service.t should work now)
Affected files ...
... //depot/perl/MANIFEST#958 edit
... //depot/perl/lib/Net/Ping.pm#35 edit
... //depot/perl/lib/Net/Ping/t/400_ping_syn.t#2 edit
... //depot/perl/lib/Net/Ping/t/410_syn_host.t#1 add
... //depot/perl/lib/Net/Ping/t/450_service.t#4 edit
Differences ...
//depot/perl/MANIFEST#958 (text)
Index: perl/MANIFEST
--- perl/MANIFEST#957~18280~Tue Dec 10 13:30:10 2002
+++ perl/MANIFEST Mon Dec 16 18:58:12 2002
@@ -1348,6 +1348,7 @@
lib/Net/Ping/t/300_ping_stream.t Ping Net::Ping
lib/Net/Ping/t/300_ping_stream.t Ping Net::Ping
lib/Net/Ping/t/400_ping_syn.t Ping Net::Ping
+lib/Net/Ping/t/410_syn_host.t Ping Net::Ping
lib/Net/Ping/t/450_service.t Ping Net::Ping
lib/Net/POP3.pmlibnet
lib/Net/protoent.pmBy-name interface to Perl's builtin getproto*
//depot/perl/lib/Net/Ping.pm#35 (text)
Index: perl/lib/Net/Ping.pm
--- perl/lib/Net/Ping.pm#34~18038~ Sun Oct 20 07:23:06 2002
+++ perl/lib/Net/Ping.pmMon Dec 16 18:58:12 2002
@@ -1,6 +1,6 @@
package Net::Ping;
-# $Id: Ping.pm,v 1.33 2002/10/19 05:02:43 rob Exp $
+# $Id: Ping.pm,v 1.46 2002/12/02 19:17:09 rob Exp $
require 5.002;
require Exporter;
@@ -11,13 +11,13 @@
use Fcntl qw( F_GETFL F_SETFL O_NONBLOCK );
use Socket qw( SOCK_DGRAM SOCK_STREAM SOCK_RAW PF_INET SOL_SOCKET
inet_aton inet_ntoa sockaddr_in );
-use POSIX qw( ECONNREFUSED EINPROGRESS WNOHANG );
+use POSIX qw( ECONNREFUSED EINPROGRESS EAGAIN WNOHANG );
use FileHandle;
use Carp;
@ISA = qw(Exporter);
@EXPORT = qw(pingecho);
-$VERSION = "2.23";
+$VERSION = "2.26";
# Constants
@@ -157,6 +157,8 @@
$self->{"fork_wr"} = FileHandle->new();
pipe($self->{"fork_rd"}, $self->{"fork_wr"});
$self->{"fh"} = FileHandle->new();
+ $self->{"good"} = {};
+ $self->{"bad"} = {};
} else {
$self->{"wbits"} = "";
$self->{"bad"} = {};
@@ -665,7 +667,8 @@
# of time. Return the result of our efforts.
use constant UDP_FLAGS => 0; # Nothing special on send or recv
-
+# XXX - Use concept by rdw @ perlmonks
+# http://perlmonks.thepen.com/42898.html
sub ping_udp
{
my ($self,
@@ -761,8 +764,11 @@
}
# Set O_NONBLOCK property on filehandle
- if (my $flags = fcntl($fh, F_GETFL, 0)) {
-fcntl($fh, F_SETFL, $flags | O_NONBLOCK);
+ my $flags = 0;
+ if (fcntl($fh, F_GETFL, $flags)) {
+if (!fcntl($fh, F_SETFL, $flags | O_NONBLOCK)) {
+ croak("fcntl F_SETFL: $!");
+}
} else {
croak("fcntl F_GETFL: $!");
}
@@ -771,16 +777,18 @@
# by just sending the TCP SYN packet
if (connect($fh, $saddr)) {
# Non-blocking, yet still connected?
-# Must have connected very quickly.
-# Can this ever really happen?
- }
- else {
+# Must have connected very quickly,
+# or else it wasn't very non-blocking.
+#warn "WARNING: Nonblocking connect connected anyway? ($^O)";
+ } else {
# Error occurred connecting.
-# Hopefully the connection is just still in progress.
-if ($! != EINPROGRESS) {
- # If not, then it really is something bad.
+if ($! == EINPROGRESS) {
+ # The connection is just still in progress.
+ # This is the expected condition.
+} else {
+ # Just save the error and continue on.
+ # The ack() can check the status later.
$self->{"bad"}->{$host} = $!;
- return undef;
}
}
@@ -863,7 +871,16 @@
if (my $host = shift) {
# Host passed as arg
if (exists $self->{"bad"}->{$host}) {
-return ();
+if (!$self->{"tcp_econnrefused"} &&
+$self->{"bad"}->{ $host } &&
+(($! = ECONNREFUSED)>0) &&
+$self->{"bad"}->{ $host } eq "$!") {
+ # "Connection refused" means reachable
+ # Good, continue
+} else {
+ # ECONNREFUSED means no good
+ return ();
+}
}
my $host_fd = undef;
foreach my $fd (keys %{ $self->{"syn"} }) {
@@ -889,46 +906,75 @@
while ($wbits !~ /^\0*$/) {
my $timeout = $stop_time - &time();
# Force a minimum of 10 ms timeout.
- $timeout = 0.01 if $timeout <= .01;
- if (my $nfound = select(undef, (my $wout=$wbits), undef, $timeout)) {
-# Done waiting for one of the ACKs
-my $fd = 0;
-# Determine which one
-while (length $wout &&
- !vec($wout, $fd, 1)) {
- $fd++;
+ $timeout = 0.01 if $timeout <= 0.01;
+
+ my $winner_fd = undef;
+ my $wout = $wbits;
+ my $fd = 0;
+ # Do "bad" fds from $wbits first
+ while ($wout !~ /^\0*$/) {
+if (vec($wout, $fd, 1)) {
+ # Wipe it from future scanning.
+ vec($wout, $fd, 1) = 0;
+ if (my $entry = $self->{"syn"}->{$fd}) {
+if ($self->{"bad"}->{ $entry->[0] }) {
+
Change 18318: Re: [PATCH] Re: [perl #19022] POSIX failures in bleadperl
Change 18318 by [EMAIL PROTECTED] on 2002/12/17 03:12:18 Subject: Re: [PATCH] Re: [perl #19022] POSIX failures in bleadperl From: Nicholas Clark <[EMAIL PROTECTED]> Date: Sat, 14 Dec 2002 23:13:37 + Message-ID: <[EMAIL PROTECTED]> Affected files ... ... //depot/perl/pad.c#9 edit ... //depot/perl/t/op/eval.t#25 edit Differences ... End of Patch.
