Change 14433 by jhi@alpha on 2002/01/26 21:38:56
Integrate perlio;
1st two tests of File/Find/t/find.t and taint.t were run after
calling cleanup(). If previous fail had left for_find directory,
but no content in it then cleanup() returned cd'ed to that directory.
So tests failed. Fixed cleanup()-s.
If we get to sighandler by mistake (no perl handler set) then
warn() and exit() rather than die() - should never happen
but if it does context needed to die is likely to be trashed
as well.
Win32 signal emulation cleanup.
Tinkering with thread cleanup mutex-ing - not the problem
(op.c is) but could have been...
Fix/band-aid for op.c's anon CV leak fix co-existing with threads.
Should really be looked at by someone that knows about pads.
Gurusamy Sarathy <[EMAIL PROTECTED]>'s patch to Filter::Simple
for CRLF line endings.
Affected files ...
.... //depot/perl/ext/threads/threads.xs#25 integrate
.... //depot/perl/lib/File/Find/t/find.t#6 integrate
.... //depot/perl/lib/File/Find/t/taint.t#7 integrate
.... //depot/perl/lib/Filter/Simple.pm#11 integrate
.... //depot/perl/mg.c#223 integrate
.... //depot/perl/op.c#481 integrate
.... //depot/perl/win32/perlhost.h#50 integrate
.... //depot/perl/win32/win32.c#188 integrate
.... //depot/perl/win32/win32.h#99 integrate
.... //depot/perl/win32/win32iop.h#36 integrate
Differences ...
==== //depot/perl/ext/threads/threads.xs#25 (xtext) ====
Index: perl/ext/threads/threads.xs
--- perl/ext/threads/threads.xs.~1~ Sat Jan 26 14:45:06 2002
+++ perl/ext/threads/threads.xs Sat Jan 26 14:45:06 2002
@@ -84,9 +84,8 @@
MUTEX_LOCK(&thread->mutex);
if (thread->count != 0) {
MUTEX_UNLOCK(&thread->mutex);
- return;
+ return;
}
- MUTEX_UNLOCK(&thread->mutex);
MUTEX_LOCK(&create_mutex);
/* Remove from circular list of threads */
if (thread->next == thread) {
@@ -114,6 +113,7 @@
thread->interp = NULL;
}
PERL_SET_CONTEXT(aTHX);
+ MUTEX_UNLOCK(&thread->mutex);
}
@@ -316,11 +316,11 @@
{
dTHXa(thread->interp);
- clone_param.flags = 0;
+ clone_param.flags = 0;
thread->init_function = sv_dup(init_function, &clone_param);
if (SvREFCNT(thread->init_function) == 0) {
SvREFCNT_inc(thread->init_function);
- }
+ }
thread->params = sv_dup(params, &clone_param);
SvREFCNT_inc(thread->params);
@@ -328,7 +328,7 @@
ptr_table_free(PL_ptr_table);
PL_ptr_table = NULL;
}
-
+
PERL_SET_CONTEXT(aTHX);
/* Start the thread */
@@ -363,7 +363,7 @@
#endif
}
#endif
- MUTEX_UNLOCK(&create_mutex);
+ MUTEX_UNLOCK(&create_mutex);
return ithread_to_SV(aTHX_ obj, thread, classname, FALSE);
}
@@ -517,4 +517,3 @@
MUTEX_UNLOCK(&create_mutex);
}
-
==== //depot/perl/lib/File/Find/t/find.t#6 (text) ====
Index: perl/lib/File/Find/t/find.t
--- perl/lib/File/Find/t/find.t.~1~ Sat Jan 26 14:45:06 2002
+++ perl/lib/File/Find/t/find.t Sat Jan 26 14:45:06 2002
@@ -48,6 +48,7 @@
require File::Find;
import File::Find;
}
+
cleanup();
find({wanted => sub { print "ok 1\n" if $_ eq 'access.t'; } },
@@ -56,27 +57,28 @@
finddepth({wanted => sub { print "ok 2\n" if $_ eq 'access.t'; } },
File::Spec->curdir);
+
my $case = 2;
my $FastFileTests_OK = 0;
sub cleanup {
if (-d dir_path('for_find')) {
chdir(dir_path('for_find'));
- }
- if (-d dir_path('fa')) {
- unlink file_path('fa', 'fa_ord'),
- file_path('fa', 'fsl'),
- file_path('fa', 'faa', 'faa_ord'),
- file_path('fa', 'fab', 'fab_ord'),
- file_path('fa', 'fab', 'faba', 'faba_ord'),
- file_path('fb', 'fb_ord'),
- file_path('fb', 'fba', 'fba_ord');
- rmdir dir_path('fa', 'faa');
- rmdir dir_path('fa', 'fab', 'faba');
- rmdir dir_path('fa', 'fab');
- rmdir dir_path('fa');
- rmdir dir_path('fb', 'fba');
- rmdir dir_path('fb');
+ if (-d dir_path('fa')) {
+ unlink file_path('fa', 'fa_ord'),
+ file_path('fa', 'fsl'),
+ file_path('fa', 'faa', 'faa_ord'),
+ file_path('fa', 'fab', 'fab_ord'),
+ file_path('fa', 'fab', 'faba', 'faba_ord'),
+ file_path('fb', 'fb_ord'),
+ file_path('fb', 'fba', 'fba_ord');
+ rmdir dir_path('fa', 'faa');
+ rmdir dir_path('fa', 'fab', 'faba');
+ rmdir dir_path('fa', 'fab');
+ rmdir dir_path('fa');
+ rmdir dir_path('fb', 'fba');
+ rmdir dir_path('fb');
+ }
chdir(File::Spec->updir);
rmdir dir_path('for_find');
}
==== //depot/perl/lib/File/Find/t/taint.t#7 (text) ====
Index: perl/lib/File/Find/t/taint.t
--- perl/lib/File/Find/t/taint.t.~1~ Sat Jan 26 14:45:06 2002
+++ perl/lib/File/Find/t/taint.t Sat Jan 26 14:45:06 2002
@@ -1,7 +1,7 @@
#!./perl -T
-my %Expect_File = (); # what we expect for $_
+my %Expect_File = (); # what we expect for $_
my %Expect_Name = (); # what we expect for $File::Find::name/fullname
my %Expect_Dir = (); # what we expect for $File::Find::dir
my ($cwd, $cwd_untainted);
@@ -51,13 +51,13 @@
my $found;
find({wanted => sub { $found = 1 if ($_ eq 'access.t') },
untaint => 1, untaint_pattern => qr|^(.+)$|}, File::Spec->curdir);
-
+
ok($found, 'access.t found');
$found = 0;
-
+
finddepth({wanted => sub { $found = 1 if $_ eq 'access.t'; },
untaint => 1, untaint_pattern => qr|^(.+)$|}, File::Spec->curdir);
-
+
ok($found, 'access.t found again');
my $case = 2;
@@ -66,21 +66,21 @@
sub cleanup {
if (-d dir_path('for_find')) {
chdir(dir_path('for_find'));
- }
- if (-d dir_path('fa')) {
- unlink file_path('fa', 'fa_ord'),
- file_path('fa', 'fsl'),
- file_path('fa', 'faa', 'faa_ord'),
- file_path('fa', 'fab', 'fab_ord'),
- file_path('fa', 'fab', 'faba', 'faba_ord'),
- file_path('fb', 'fb_ord'),
- file_path('fb', 'fba', 'fba_ord');
- rmdir dir_path('fa', 'faa');
- rmdir dir_path('fa', 'fab', 'faba');
- rmdir dir_path('fa', 'fab');
- rmdir dir_path('fa');
- rmdir dir_path('fb', 'fba');
- rmdir dir_path('fb');
+ if (-d dir_path('fa')) {
+ unlink file_path('fa', 'fa_ord'),
+ file_path('fa', 'fsl'),
+ file_path('fa', 'faa', 'faa_ord'),
+ file_path('fa', 'fab', 'fab_ord'),
+ file_path('fa', 'fab', 'faba', 'faba_ord'),
+ file_path('fb', 'fb_ord'),
+ file_path('fb', 'fba', 'fba_ord');
+ rmdir dir_path('fa', 'faa');
+ rmdir dir_path('fa', 'fab', 'faba');
+ rmdir dir_path('fa', 'fab');
+ rmdir dir_path('fa');
+ rmdir dir_path('fb', 'fba');
+ rmdir dir_path('fb');
+ }
chdir File::Spec->updir;
rmdir dir_path('for_find');
}
@@ -104,10 +104,10 @@
s#\.$## if ($^O eq 'VMS' && $_ ne '.');
ok( $Expect_File{$_}, "Expected and found $File::Find::name" );
if ( $FastFileTests_OK ) {
- delete $Expect_File{ $_}
+ delete $Expect_File{ $_}
unless ( $Expect_Dir{$_} && ! -d _ );
} else {
- delete $Expect_File{$_}
+ delete $Expect_File{$_}
unless ( $Expect_Dir{$_} && ! -d $_ );
}
}
@@ -131,7 +131,7 @@
# directory path, independent from the platform it's run on, although
# there are limitations. Don't try to create an absolute path,
# because that may fail on operating systems that have the concept of
-# volume names (e.g. Mac OS). As a special case, you can pass it a "."
+# volume names (e.g. Mac OS). As a special case, you can pass it a "."
# as first argument, to create a directory path like "./fa/dir" on
# operating systems other than Mac OS (actually, Mac OS will ignore
# the ".", if it's the first argument). If there's no second argument,
@@ -146,7 +146,7 @@
return '' unless @_;
# ignore first argument; return a relative path
# with leading ":" and with trailing ":"
- return File::Spec->catdir(@_);
+ return File::Spec->catdir(@_);
} else { # other OS
return './' unless @_;
my $path = File::Spec->catdir(@_);
@@ -179,11 +179,11 @@
# file_path() concatenates directory names (if any) and a filename to
# form a *relative* file path (the last argument is assumed to be a
# file). It's independent from the platform it's run on, although
-# there are limitations. As a special case, you can pass it a "." as
-# first argument, to create a file path like "./fa/file" on operating
-# systems other than Mac OS (actually, Mac OS will ignore the ".", if
-# it's the first argument). If there's no second argument, this
-# function will return the empty string on Mac OS and the string "./"
+# there are limitations. As a special case, you can pass it a "." as
+# first argument, to create a file path like "./fa/file" on operating
+# systems other than Mac OS (actually, Mac OS will ignore the ".", if
+# it's the first argument). If there's no second argument, this
+# function will return the empty string on Mac OS and the string "./"
# otherwise.
sub file_path {
@@ -192,14 +192,14 @@
if ($first_arg eq '.') {
if ($^O eq 'MacOS') {
return '' unless @_;
- # ignore first argument; return a relative path
+ # ignore first argument; return a relative path
# with leading ":", but without trailing ":"
- return File::Spec->catfile(@_);
+ return File::Spec->catfile(@_);
} else { # other OS
return './' unless @_;
my $path = File::Spec->catfile(@_);
- # add leading "./"
- $path = "./$path";
+ # add leading "./"
+ $path = "./$path";
return $path;
}
@@ -288,7 +288,7 @@
chdir($cwd_untainted);
-# untaint pattern doesn't match, should die
+# untaint pattern doesn't match, should die
undef $@;
eval {File::Find::find( {wanted => \&simple_wanted, untaint => 1,
@@ -299,7 +299,7 @@
chdir($cwd_untainted);
-# untaint pattern doesn't match, should die when we chdir to cwd
+# untaint pattern doesn't match, should die when we chdir to cwd
print "# check untaint_skip (No follow)\n";
undef $@;
@@ -310,7 +310,7 @@
print "# $@" if $@;
#$^D = 8;
like( $@, qr|insecure cwd|, 'Bad untaint pattern causes death in cwd (good)' );
-
+
chdir($cwd_untainted);
@@ -351,8 +351,8 @@
qr|^(.+)$| }, topdir('fa') );
is( scalar(keys %Expect_File), 0, 'Found all files in symlink test' );
-
-
+
+
# don't untaint at all, should die
undef $@;
@@ -382,5 +382,4 @@
like( $@, qr|insecure cwd|, 'Cwd not untainted with bad pattern (good)' );
chdir($cwd_untainted);
-}
-
+}
==== //depot/perl/lib/Filter/Simple.pm#11 (text) ====
Index: perl/lib/Filter/Simple.pm
--- perl/lib/Filter/Simple.pm.~1~ Sat Jan 26 14:45:06 2002
+++ perl/lib/Filter/Simple.pm Sat Jan 26 14:45:06 2002
@@ -44,7 +44,7 @@
| ^=pod .*? $CUT
| ^=for .*? $EOP
| ^=begin \s* (\S+) .*? \n=end \s* \1 .*? $EOP
- | ^__(DATA|END)__\n.*
+ | ^__(DATA|END)__\r?\n.*
/smx;
my %extractor_for = (
@@ -153,7 +153,7 @@
return sub {
my ($imported_class, @args) = @_;
my $def_terminator =
- qr/^(?:\s*no\s+$imported_class\s*;$ows|__(?:END|DATA)__)$/;
+ qr/^(?:\s*no\s+$imported_class\s*;$ows|__(?:END|DATA)__)\r?$/;
if (!defined $terminator) {
$terminator{terminator} = $def_terminator;
}
==== //depot/perl/mg.c#223 (text) ====
Index: perl/mg.c
--- perl/mg.c.~1~ Sat Jan 26 14:45:06 2002
+++ perl/mg.c Sat Jan 26 14:45:06 2002
@@ -275,7 +275,7 @@
for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
MGVTBL* vtbl = mg->mg_virtual;
/* omit GSKIP -- never set here */
-
+
if (vtbl && vtbl->svt_clear)
CALL_FPTR(vtbl->svt_clear)(aTHX_ sv, mg);
}
@@ -408,7 +408,7 @@
i = t;
else /* @- */
i = s;
-
+
if (i > 0 && PL_reg_match_utf8) {
char *b = rx->subbeg;
if (b)
@@ -548,11 +548,11 @@
#ifdef MACOS_TRADITIONAL
{
char msg[256];
-
+
sv_setnv(sv,(double)gMacPerl_OSErr);
- sv_setpv(sv, gMacPerl_OSErr ? GetSysErrText(gMacPerl_OSErr, msg) :
"");
+ sv_setpv(sv, gMacPerl_OSErr ? GetSysErrText(gMacPerl_OSErr, msg) :
+"");
}
-#else
+#else
#ifdef VMS
{
# include <descrip.h>
@@ -1521,7 +1521,7 @@
sv_pos_u2b(lsv, &p, 0);
pos = p;
}
-
+
mg->mg_len = pos;
mg->mg_flags &= ~MGf_MINMATCH;
@@ -1945,7 +1945,7 @@
else if (isWARN_on(sv, WARN_ALL) && !any_fatals) {
PL_compiling.cop_warnings = pWARN_ALL;
PL_dowarn |= G_WARN_ONCE ;
- }
+ }
else {
if (specialWARN(PL_compiling.cop_warnings))
PL_compiling.cop_warnings = newSVsv(sv) ;
@@ -2347,9 +2347,11 @@
if (PL_scopestack_ix < PL_scopestack_max - 3)
flags |= 16;
- if (!PL_psig_ptr[sig])
- Perl_die(aTHX_ "Signal SIG%s received, but no signal handler set.\n",
- PL_sig_name[sig]);
+ if (!PL_psig_ptr[sig]) {
+ Perl_warn(aTHX_ "Signal SIG%s received, but no signal handler set.\n",
+ PL_sig_name[sig]);
+ exit(sig);
+ }
/* Max number of items pushed there is 3*n or 4. We cannot fix
infinity, so we fix 4 (in fact 5): */
@@ -2493,4 +2495,3 @@
}
-
==== //depot/perl/op.c#481 (text) ====
Index: perl/op.c
--- perl/op.c.~1~ Sat Jan 26 14:45:06 2002
+++ perl/op.c Sat Jan 26 14:45:06 2002
@@ -1487,7 +1487,7 @@
|| kid->op_type == OP_METHOD)
{
UNOP *newop;
-
+
NewOp(1101, newop, 1, UNOP);
newop->op_type = OP_RV2CV;
newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
@@ -1497,7 +1497,7 @@
newop->op_private |= OPpLVAL_INTRO;
break;
}
-
+
if (kid->op_type != OP_RV2CV)
Perl_croak(aTHX_
"panic: unexpected lvalue entersub "
@@ -1506,12 +1506,12 @@
kid->op_private |= OPpLVAL_INTRO;
break; /* Postpone until runtime */
}
-
- okid = kid;
+
+ okid = kid;
kid = kUNOP->op_first;
if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
kid = kUNOP->op_first;
- if (kid->op_type == OP_NULL)
+ if (kid->op_type == OP_NULL)
Perl_croak(aTHX_
"Unexpected constant lvalue entersub "
"entry via type/targ %ld:%"UVuf,
@@ -1531,7 +1531,7 @@
okid->op_private |= OPpLVAL_INTRO;
break;
}
-
+
cv = GvCV(kGVOP_gv);
if (!cv)
goto restore_2cv;
@@ -1578,7 +1578,7 @@
goto nomod;
PL_modcount++;
break;
-
+
case OP_COND_EXPR:
for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
mod(kid, type);
@@ -1649,7 +1649,7 @@
case OP_PUSHMARK:
break;
-
+
case OP_KEYS:
if (type != OP_SASSIGN)
goto nomod;
@@ -3714,7 +3714,7 @@
if (gv == PL_defgv || SvCUR(gv) == PL_generation)
break;
SvCUR(gv) = PL_generation;
- }
+ }
}
else
break;
@@ -4431,7 +4431,8 @@
for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
SV *namesv = namepad[ix];
if (namesv && namesv != &PL_sv_undef
- && *SvPVX(namesv) == '&')
+ && *SvPVX(namesv) == '&'
+ && ix <= AvFILLp(comppad))
{
CV *innercv = (CV*)curpad[ix];
if (innercv && SvTYPE(innercv) == SVt_PVCV
@@ -5421,7 +5422,7 @@
o->op_type = OP_PADAV;
o->op_ppaddr = PL_ppaddr[OP_PADAV];
return ref(o, OP_RV2AV);
-
+
case OP_RV2SV:
o->op_type = OP_RV2AV;
o->op_ppaddr = PL_ppaddr[OP_RV2AV];
@@ -5582,7 +5583,7 @@
!(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
-
+
return o;
}
op_free(kUNOP->op_first);
@@ -5949,7 +5950,7 @@
Perl_warner(aTHX_ WARN_SYNTAX,
"Useless use of %s with no values",
PL_op_desc[type]);
-
+
if (kid->op_type == OP_CONST &&
(kid->op_private & OPpCONST_BARE))
{
@@ -6299,7 +6300,7 @@
kid = kid->op_sibling;
}
}
-
+
if (!kid)
append_elem(o->op_type, o, newDEFSVOP());
@@ -6507,7 +6508,7 @@
if (!(o->op_flags & OPf_KIDS)) {
OP *argop;
-
+
op_free(o);
#ifdef USE_5005THREADS
if (!CvUNIQUE(PL_compcv)) {
@@ -7208,7 +7209,7 @@
}
}
break;
-
+
case OP_HELEM: {
UNOP *rop;
SV *lexname;
@@ -7217,7 +7218,7 @@
I32 ind;
char *key = NULL;
STRLEN keylen;
-
+
o->op_seq = PL_op_seqmax++;
if (((BINOP*)o)->op_last->op_type != OP_CONST)
@@ -7269,7 +7270,7 @@
*svp = sv;
break;
}
-
+
case OP_HSLICE: {
UNOP *rop;
SV *lexname;
@@ -7399,4 +7400,3 @@
ST(0) = (SV*)XSANY.any_ptr;
XSRETURN(1);
}
-
==== //depot/perl/win32/perlhost.h#50 (text) ====
Index: perl/win32/perlhost.h
--- perl/win32/perlhost.h.~1~ Sat Jan 26 14:45:06 2002
+++ perl/win32/perlhost.h Sat Jan 26 14:45:06 2002
@@ -225,7 +225,7 @@
#define STRUCT2RAWPTR(x, y) (CPerlHost*)(((LPBYTE)x)-offsetof(CPerlHost, y))
#ifdef CHECK_HOST_INTERP
-inline CPerlHost* CheckInterp(CPerlHost *host)
+inline CPerlHost* CheckInterp(CPerlHost *host)
{
win32_checkTLS(host->host_perl);
return host;
@@ -1678,7 +1678,7 @@
Sighandler_t
PerlProcSignal(struct IPerlProc* piPerl, int sig, Sighandler_t subcode)
{
- return signal(sig, subcode);
+ return win32_signal(sig, subcode);
}
#ifdef USE_ITHREADS
@@ -2162,7 +2162,7 @@
if(c1 != c2) {
if(c1 < c2)
return -1; // string 1 < string 2
-
+
return 1; // string 1 > string 2
}
}
@@ -2290,7 +2290,7 @@
lpStr += nLength;
lpEnvPtr += nLength;
}
- else {
+ else {
// determine which string to copy next
compVal = compare(&lpEnvPtr, &lpLocalEnv);
if(compVal < 0) {
@@ -2434,4 +2434,3 @@
}
#endif /* ___PerlHost_H___ */
-
==== //depot/perl/win32/win32.c#188 (text) ====
Index: perl/win32/win32.c
--- perl/win32/win32.c.~1~ Sat Jan 26 14:45:06 2002
+++ perl/win32/win32.c Sat Jan 26 14:45:06 2002
@@ -1,13 +1,13 @@
/* WIN32.C
*
- * (c) 1995 Microsoft Corporation. All rights reserved.
+ * (c) 1995 Microsoft Corporation. All rights reserved.
* Developed by hip communications inc., http://info.hip.com/info/
* Portions (c) 1993 Intergraph Corporation. All rights reserved.
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
*/
-#define PERLIO_NOT_STDIO 0
+#define PERLIO_NOT_STDIO 0
#define WIN32_LEAN_AND_MEAN
#define WIN32IO_IS_STDIO
#include <tchar.h>
@@ -54,7 +54,7 @@
#include <utime.h>
#endif
#ifdef __GNUC__
-/* Mingw32 defaults to globing command line
+/* Mingw32 defaults to globing command line
* So we turn it off like this:
*/
int _CRT_glob = 0;
@@ -118,7 +118,7 @@
#define ONE_K_BUFSIZE 1024
-int
+int
IsWin95(void)
{
return (win32_os_id() == VER_PLATFORM_WIN32_WINDOWS);
@@ -549,7 +549,7 @@
argv[index++] = "";
}
argv[index++] = 0;
-
+
status = win32_spawnvp(flag,
(const char*)(really ? SvPV_nolen(really) : argv[0]),
(const char* const*)argv);
@@ -562,7 +562,7 @@
argv[index+sh_items] = argv[index];
while (--sh_items >= 0)
argv[sh_items] = w32_perlshell_vec[sh_items];
-
+
status = win32_spawnvp(flag,
(const char*)(really ? SvPV_nolen(really) : argv[0]),
(const char* const*)argv);
@@ -881,7 +881,7 @@
dirp->curr = NULL;
}
return &(dirp->dirstr);
- }
+ }
else
return NULL;
}
@@ -963,7 +963,7 @@
int
setuid(uid_t auid)
-{
+{
return (auid == ROOT_UID ? 0 : -1);
}
@@ -1096,7 +1096,7 @@
default:
/* We fake signals to pseudo-processes using Win32 message queue */
if (PostThreadMessage(-pid,WM_USER,sig,0)) {
- /* It might be us ... */
+ /* It might be us ... */
PERL_ASYNC_CHECK();
return 0;
}
@@ -1162,7 +1162,7 @@
win32_stat(const char *path, struct stat *sbuf)
{
dTHX;
- char buffer[MAX_PATH+1];
+ char buffer[MAX_PATH+1];
int l = strlen(path);
int res;
WCHAR wbuffer[MAX_PATH+1];
@@ -1477,14 +1477,14 @@
FILETIME user;
FILETIME kernel;
FILETIME dummy;
- if (GetProcessTimes(GetCurrentProcess(), &dummy, &dummy,
+ if (GetProcessTimes(GetCurrentProcess(), &dummy, &dummy,
&kernel,&user)) {
timebuf->tms_utime = filetime_to_clock(&user);
timebuf->tms_stime = filetime_to_clock(&kernel);
timebuf->tms_cutime = 0;
timebuf->tms_cstime = 0;
-
- } else {
+
+ } else {
/* That failed - e.g. Win95 fallback to clock() */
clock_t t = clock();
timebuf->tms_utime = t;
@@ -1714,6 +1714,49 @@
/* Timing related stuff */
+int
+do_raise(pTHX_ int sig)
+{
+ if (sig < SIG_SIZE) {
+ Sighandler_t handler = w32_sighandler[sig];
+ if (handler == SIG_IGN) {
+ return 0;
+ }
+ else if (handler != SIG_DFL) {
+ (*handler)(sig);
+ return 0;
+ }
+ else {
+ /* Choose correct default behaviour */
+ switch (sig) {
+#ifdef SIGCLD
+ case SIGCLD:
+#endif
+#ifdef SIGCHLD
+ case SIGCHLD:
+#endif
+ case 0:
+ return 0;
+ case SIGTERM:
+ default:
+ break;
+ }
+ }
+ }
+ /* Tell caller to exit thread/process as approriate */
+ return 1;
+}
+
+void
+sig_terminate(pTHX_ int sig)
+{
+ Perl_warn(aTHX_ "Terminating on signal SIG%s(%d)\n",PL_sig_name[sig], sig);
+ /* exit() seems to be safe, my_exit() or die() is a problem in ^C
+ thread
+ */
+ exit(sig);
+}
+
DllExport int
win32_async_check(pTHX)
{
@@ -1721,33 +1764,41 @@
int ours = 1;
/* Passing PeekMessage -1 as HWND (2nd arg) only get PostThreadMessage() messages
* and ignores window messages - should co-exist better with windows apps e.g. Tk
- */
+ */
while (PeekMessage(&msg, (HWND)-1, 0, 0, PM_REMOVE|PM_NOYIELD)) {
+ int sig;
switch(msg.message) {
#if 0
/* Perhaps some other messages could map to signals ? ... */
case WM_CLOSE:
- case WM_QUIT:
+ case WM_QUIT:
/* Treat WM_QUIT like SIGHUP? */
- CALL_FPTR(PL_sighandlerp)(1);
+ sig = SIGHUP;
+ goto Raise;
break;
#endif
/* We use WM_USER to fake kill() with other signals */
case WM_USER: {
- CALL_FPTR(PL_sighandlerp)(msg.wParam);
+ sig = msg.wParam;
+ Raise:
+ if (do_raise(aTHX_ sig)) {
+ sig_terminate(aTHX_ sig);
+ }
break;
}
-
+
case WM_TIMER: {
/* alarm() is a one-shot but SetTimer() repeats so kill it */
if (w32_timerid) {
KillTimer(NULL,w32_timerid);
- w32_timerid=0;
- }
+ w32_timerid=0;
+ }
/* Now fake a call to signal handler */
- CALL_FPTR(PL_sighandlerp)(14);
+ if (do_raise(aTHX_ 14)) {
+ sig_terminate(aTHX_ 14);
+ }
break;
}
@@ -1765,7 +1816,7 @@
if (PL_sig_pending) {
despatch_signals();
}
- return ours;
+ return ours;
}
DllExport DWORD
@@ -1782,9 +1833,9 @@
if (resultp)
*resultp = result;
if (result == WAIT_TIMEOUT) {
- /* Ran out of time - explicit return of zero to avoid -ve if we
- have scheduling issues
- */
+ /* Ran out of time - explicit return of zero to avoid -ve if we
+ have scheduling issues
+ */
return 0;
}
if (timeout != INFINITE) {
@@ -1952,7 +2003,7 @@
errno = ECHILD;
}
}
- return retval >= 0 ? pid : retval;
+ return retval >= 0 ? pid : retval;
}
DllExport int
@@ -1972,12 +2023,12 @@
DllExport unsigned int
win32_alarm(unsigned int sec)
{
- /*
+ /*
* the 'obvious' implentation is SetTimer() with a callback
- * which does whatever receiving SIGALRM would do
- * we cannot use SIGALRM even via raise() as it is not
+ * which does whatever receiving SIGALRM would do
+ * we cannot use SIGALRM even via raise() as it is not
* one of the supported codes in <signal.h>
- */
+ */
dTHX;
if (sec) {
w32_timerid = SetTimer(NULL,w32_timerid,sec*1000,NULL);
@@ -1985,9 +2036,9 @@
else {
if (w32_timerid) {
KillTimer(NULL,w32_timerid);
- w32_timerid=0;
+ w32_timerid=0;
}
- }
+ }
return 0;
}
@@ -2195,13 +2246,13 @@
}
/*
- * Since the errors returned by the socket error function
+ * Since the errors returned by the socket error function
* WSAGetLastError() are not known by the library routine strerror
* we have to roll our own.
*/
DllExport char *
-win32_strerror(int e)
+win32_strerror(int e)
{
#if !defined __BORLANDC__ && !defined __MINGW32__ /* compiler intolerance */
extern int sys_nerr;
@@ -2215,7 +2266,7 @@
if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, &source, e, 0,
w32_strerror_buffer,
- sizeof(w32_strerror_buffer), NULL) == 0)
+ sizeof(w32_strerror_buffer), NULL) == 0)
strcpy(w32_strerror_buffer, "Unknown Error");
return w32_strerror_buffer;
@@ -2305,7 +2356,7 @@
dTHX;
WCHAR wMode[MODE_SIZE], wBuffer[MAX_PATH+1];
FILE *f;
-
+
if (!*filename)
return NULL;
@@ -2488,7 +2539,7 @@
/* A file designated by filehandle is not shown as accessible
* for write operations, probably because it is opened for reading.
* --Vadim Konovalov
- */
+ */
int rc = fstat(fd,sbufptr);
BY_HANDLE_FILE_INFORMATION bhfi;
if (GetFileInformationByHandle((HANDLE)_get_osfhandle(fd), &bhfi)) {
@@ -3122,7 +3173,7 @@
bytes_read = q - (char *)buf;
}
-functionexit:
+functionexit:
if (_pioinfo(fh)->lockinitflag)
LeaveCriticalSection(&(_pioinfo(fh)->lock)); /* unlock file */
@@ -3524,7 +3575,7 @@
* This doesn't significantly affect perl itself, because we
* always invoke things using PERL5SHELL if a direct attempt to
* spawn the executable fails.
- *
+ *
* XXX splitting and rejoining the commandline between do_aspawn()
* and win32_spawnvp() could also be avoided.
*/
@@ -3578,10 +3629,10 @@
ret = -1;
goto RETVAL;
}
- /* Create a new process group so we can use GenerateConsoleCtrlEvent()
+ /* Create a new process group so we can use GenerateConsoleCtrlEvent()
* in win32_kill()
*/
- create |= CREATE_NEW_PROCESS_GROUP;
+ create |= CREATE_NEW_PROCESS_GROUP;
/* FALL THROUGH */
case P_WAIT: /* synchronous execution */
@@ -3596,14 +3647,14 @@
memset(&tbl,0,sizeof(tbl));
PerlEnv_get_child_IO(&tbl);
StartupInfo.dwFlags = tbl.dwFlags;
- StartupInfo.dwX = tbl.dwX;
- StartupInfo.dwY = tbl.dwY;
- StartupInfo.dwXSize = tbl.dwXSize;
- StartupInfo.dwYSize = tbl.dwYSize;
- StartupInfo.dwXCountChars = tbl.dwXCountChars;
- StartupInfo.dwYCountChars = tbl.dwYCountChars;
- StartupInfo.dwFillAttribute = tbl.dwFillAttribute;
- StartupInfo.wShowWindow = tbl.wShowWindow;
+ StartupInfo.dwX = tbl.dwX;
+ StartupInfo.dwY = tbl.dwY;
+ StartupInfo.dwXSize = tbl.dwXSize;
+ StartupInfo.dwYSize = tbl.dwYSize;
+ StartupInfo.dwXCountChars = tbl.dwXCountChars;
+ StartupInfo.dwYCountChars = tbl.dwYCountChars;
+ StartupInfo.dwFillAttribute = tbl.dwFillAttribute;
+ StartupInfo.wShowWindow = tbl.wShowWindow;
StartupInfo.hStdInput = tbl.childStdIn;
StartupInfo.hStdOutput = tbl.childStdOut;
StartupInfo.hStdError = tbl.childStdErr;
@@ -3817,7 +3868,7 @@
allocsize = info.dwAllocationGranularity;
}
/* This scheme fails eventually if request for contiguous
- * block is denied so reserve big blocks - this is only
+ * block is denied so reserve big blocks - this is only
* address space not memory ...
*/
if (brk+need >= reserved)
@@ -3831,7 +3882,7 @@
if (addr)
committed = reserved;
}
- /* Reserve some (more) space
+ /* Reserve some (more) space
* Note this is a little sneaky, 1st call passes NULL as reserved
* so lets system choose where we start, subsequent calls pass
* the old end address so ask for a contiguous block
@@ -3957,10 +4008,10 @@
dXSARGS;
/* Make the host for current directory */
char* ptr = PerlEnv_get_childdir();
- /*
- * If ptr != Nullch
- * then it worked, set PV valid,
- * else return 'undef'
+ /*
+ * If ptr != Nullch
+ * then it worked, set PV valid,
+ * else return 'undef'
*/
if (ptr) {
SV *sv = sv_newmortal();
@@ -4457,11 +4508,11 @@
if (!my_perl) {
my_perl = PL_curinterp;
PERL_SET_THX(my_perl);
- }
+ }
return my_perl;
}
-BOOL WINAPI
+BOOL WINAPI
win32_ctrlhandler(DWORD dwCtrlType)
{
dTHXa(PERL_GET_SIG_CONTEXT);
@@ -4471,43 +4522,45 @@
switch(dwCtrlType) {
case CTRL_CLOSE_EVENT:
- /* A signal that the system sends to all processes attached to a console when
- the user closes the console (either by choosing the Close command from the
- console window's System menu, or by choosing the End Task command from the
+ /* A signal that the system sends to all processes attached to a console when
+ the user closes the console (either by choosing the Close command from the
+ console window's System menu, or by choosing the End Task command from the
Task List
*/
- CALL_FPTR(PL_sighandlerp)(1); /* SIGHUP */
- return TRUE;
+ if (do_raise(aTHX_ 1)) /* SIGHUP */
+ sig_terminate(aTHX_ 1);
+ return TRUE;
case CTRL_C_EVENT:
/* A CTRL+c signal was received */
- CALL_FPTR(PL_sighandlerp)(SIGINT); /* SIGINT */
- return TRUE;
+ if (do_raise(aTHX_ SIGINT))
+ sig_terminate(aTHX_ SIGINT);
+ return TRUE;
case CTRL_BREAK_EVENT:
/* A CTRL+BREAK signal was received */
- CALL_FPTR(PL_sighandlerp)(SIGBREAK); /* unix calls it SIGQUIT */
- return TRUE;
+ if (do_raise(aTHX_ SIGBREAK))
+ sig_terminate(aTHX_ SIGBREAK);
+ return TRUE;
case CTRL_LOGOFF_EVENT:
- /* A signal that the system sends to all console processes when a user is
logging
- off. This signal does not indicate which user is logging off, so no
- assumptions can be made.
+ /* A signal that the system sends to all console processes when a user is
+logging
+ off. This signal does not indicate which user is logging off, so no
+ assumptions can be made.
*/
- break;
+ break;
case CTRL_SHUTDOWN_EVENT:
- /* A signal that the system sends to all console processes when the system is
- shutting down.
+ /* A signal that the system sends to all console processes when the system is
+ shutting down.
*/
- CALL_FPTR(PL_sighandlerp)(SIGTERM);
- return TRUE;
- break;
+ if (do_raise(aTHX_ SIGTERM))
+ sig_terminate(aTHX_ SIGTERM);
+ return TRUE;
default:
- break;
+ break;
}
return FALSE;
}
-
void
@@ -4533,6 +4586,27 @@
ptbl->childStdErr = GetStdHandle(STD_ERROR_HANDLE);
}
+Sighandler_t
+win32_signal(int sig, Sighandler_t subcode)
+{
+ dTHX;
+ if (sig < SIG_SIZE) {
+ int save_errno = errno;
+ Sighandler_t result = signal(sig, subcode);
+ if (result == SIG_ERR) {
+ result = w32_sighandler[sig];
+ errno = save_errno;
+ }
+ w32_sighandler[sig] = subcode;
+ return result;
+ }
+ else {
+ errno = EINVAL;
+ return SIG_ERR;
+ }
+}
+
+
#ifdef HAVE_INTERP_INTERN
@@ -4549,6 +4623,7 @@
void
Perl_sys_intern_init(pTHX)
{
+ int i;
w32_perlshell_tokens = Nullch;
w32_perlshell_vec = (char**)NULL;
w32_perlshell_items = 0;
@@ -4563,11 +4638,14 @@
w32_init_socktype = 0;
w32_timerid = 0;
w32_poll_count = 0;
+ for (i=0; i < SIG_SIZE; i++) {
+ w32_sighandler[i] = SIG_DFL;
+ }
if (my_perl == PL_curinterp) {
- /* Force C runtime signal stuff to set its console handler */
+ /* Force C runtime signal stuff to set its console handler */
signal(SIGINT,&win32_csighandler);
signal(SIGBREAK,&win32_csighandler);
- /* Push our handler on top */
+ /* Push our handler on top */
SetConsoleCtrlHandler(win32_ctrlhandler,TRUE);
}
}
@@ -4581,7 +4659,7 @@
Safefree(w32_children);
if (w32_timerid) {
KillTimer(NULL,w32_timerid);
- w32_timerid=0;
+ w32_timerid=0;
}
if (my_perl == PL_curinterp) {
SetConsoleCtrlHandler(win32_ctrlhandler,FALSE);
@@ -4606,6 +4684,7 @@
dst->thr_intern.Winit_socktype = 0;
dst->timerid = 0;
dst->poll_count = 0;
+ Copy(src->sigtable,dst->sigtable,SIG_SIZE,Sighandler_t);
}
# endif /* USE_ITHREADS */
#endif /* HAVE_INTERP_INTERN */
@@ -4638,7 +4717,3 @@
}
GlobalFree((HGLOBAL)lpwStr);
}
-
-
-
-
==== //depot/perl/win32/win32.h#99 (text) ====
Index: perl/win32/win32.h
--- perl/win32/win32.h.~1~ Sat Jan 26 14:45:06 2002
+++ perl/win32/win32.h Sat Jan 26 14:45:06 2002
@@ -1,6 +1,6 @@
/* WIN32.H
*
- * (c) 1995 Microsoft Corporation. All rights reserved.
+ * (c) 1995 Microsoft Corporation. All rights reserved.
* Developed by hip communications inc., http://info.hip.com/info/
*
* You may distribute under the terms of either the GNU General Public
@@ -34,15 +34,15 @@
# define Win32_Winsock
#ifdef __cplusplus
/* Mingw32 gcc -xc++ objects to __attribute((unused)) at least */
-#undef PERL_UNUSED_DECL
-#define PERL_UNUSED_DECL
+#undef PERL_UNUSED_DECL
+#define PERL_UNUSED_DECL
#endif
#endif
-/* Define DllExport akin to perl's EXT,
+/* Define DllExport akin to perl's EXT,
* If we are in the DLL or mimicing the DLL for Win95 work round
- * then Export the symbol,
+ * then Export the symbol,
* otherwise import it.
*/
@@ -51,7 +51,7 @@
#if defined(PERLDLL) || defined(WIN95FIX)
#define DllExport
/*#define DllExport __declspec(dllexport)*/ /* noises with VC5+sp3 */
-#else
+#else
#define DllExport __declspec(dllimport)
#endif
@@ -103,8 +103,8 @@
# define END_EXTERN_C }
# define EXTERN_C extern "C"
#else
-# define START_EXTERN_C
-# define END_EXTERN_C
+# define START_EXTERN_C
+# define END_EXTERN_C
# define EXTERN_C
#endif
#endif
@@ -276,14 +276,14 @@
* wShowWindow = SW_HIDE;
*/
DWORD dwFlags;
- DWORD dwX;
- DWORD dwY;
- DWORD dwXSize;
- DWORD dwYSize;
- DWORD dwXCountChars;
- DWORD dwYCountChars;
+ DWORD dwX;
+ DWORD dwY;
+ DWORD dwXSize;
+ DWORD dwYSize;
+ DWORD dwXCountChars;
+ DWORD dwYCountChars;
DWORD dwFillAttribute;
- WORD wShowWindow;
+ WORD wShowWindow;
} child_IO_table;
DllExport void win32_get_child_IO(child_IO_table* ptr);
@@ -335,8 +335,8 @@
# define PERL_SCRIPT_MODE "rb"
#endif
-/*
- * Now Win32 specific per-thread data stuff
+/*
+ * Now Win32 specific per-thread data stuff
*/
struct thread_intern {
@@ -368,6 +368,11 @@
HANDLE handles[MAXIMUM_WAIT_OBJECTS];
} child_tab;
+#ifndef Sighandler_t
+typedef Signal_t (*Sighandler_t) (int);
+#define Sighandler_t Sighandler_t
+#endif
+
struct interp_intern {
char * perlshell_tokens;
char ** perlshell_vec;
@@ -384,6 +389,7 @@
#endif
UINT timerid;
unsigned poll_count;
+ Sighandler_t sigtable[SIG_SIZE];
};
DllExport int win32_async_check(pTHX);
@@ -406,6 +412,7 @@
#define w32_pseudo_child_handles (w32_pseudo_children->handles)
#define w32_internal_host (PL_sys_intern.internal_host)
#define w32_timerid (PL_sys_intern.timerid)
+#define w32_sighandler (PL_sys_intern.sigtable)
#define w32_poll_count (PL_sys_intern.poll_count)
#define w32_do_async (w32_poll_count++ > WIN32_POLL_INTERVAL)
#ifdef USE_5005THREADS
@@ -502,7 +509,7 @@
#endif
#endif
-/* IO.xs and POSIX.xs define PERLIO_NOT_STDIO to 1 */
+/* IO.xs and POSIX.xs define PERLIO_NOT_STDIO to 1 */
#if defined(PERL_EXT_IO) || defined(PERL_EXT_POSIX)
#undef PERLIO_NOT_STDIO
#endif
@@ -530,4 +537,3 @@
#endif /* _INC_WIN32_PERL5 */
-
==== //depot/perl/win32/win32iop.h#36 (text) ====
Index: perl/win32/win32iop.h
--- perl/win32/win32iop.h.~1~ Sat Jan 26 14:45:06 2002
+++ perl/win32/win32iop.h Sat Jan 26 14:45:06 2002
@@ -7,8 +7,8 @@
# define END_EXTERN_C }
# define EXTERN_C extern "C"
#else
-# define START_EXTERN_C
-# define END_EXTERN_C
+# define START_EXTERN_C
+# define END_EXTERN_C
# define EXTERN_C
#endif
#endif
@@ -150,6 +150,8 @@
DllExport void win32_clearenv(void);
DllExport char * win32_get_childdir(void);
DllExport void win32_free_childdir(char* d);
+DllExport Sighandler_t win32_signal(int sig, Sighandler_t subcode);
+
END_EXTERN_C
@@ -324,4 +326,3 @@
#endif /* WIN32IO_IS_STDIO */
#endif /* WIN32IOP_H */
-
End of Patch.
