[PATCH] for Tk804 fork problem

The patch below should solve the problem with using fork with Tk804.
The problem was that pTk_END (in Event.xs) was called when a process
exited, which in turned called Tcl_Finalize which probably does too
much cleanup. Now pTk_END is called only for the parent process.

Regards,
        Slaven

# 
# 
# To apply this patch:
# STEP 1: Chdir to the source directory.
# STEP 2: Run the 'applypatch' program with this patch file as input.
#
# If you do not have 'applypatch', it is part of the 'makepatch' package
# that you can fetch from the Comprehensive Perl Archive Network:
# http://www.perl.com/CPAN/authors/Johan_Vromans/makepatch-x.y.tar.gz
# In the above URL, 'x' should be 2 or higher.
#
# To apply this patch without the use of 'applypatch':
# STEP 1: Chdir to the source directory.
# If you have a decent Bourne-type shell:
# STEP 2: Run the shell with this file as input.
# If you don't have such a shell, you may need to manually create
# the files as shown below.
# STEP 3: Run the 'patch' program with this file as input.
#
# These are the commands needed to create/delete files/directories:
#
touch 't/fork.t'
chmod 0775 't/fork.t'
#
# This command terminates the shell and need not be executed manually.
exit
#
#### End of Preamble ####

#### Patch data follows ####
diff -up 'Tk-804.025_beta14/Event/Event.xs' 
'Tk-804.025_beta14-perl5.8.3d/Event/Event.xs'
Index: ./Event/Event.xs
--- ./Event/Event.xs    Thu Jan 29 00:08:33 2004
+++ ./Event/Event.xs    Sun Feb  8 20:25:16 2004
@@ -1236,7 +1236,25 @@ XS(XS_Tk__Event_INIT)
 
 #define pTk_exit(status) TclpExit(status)
 
-#define pTk_END() Tcl_Finalize()
+void pTk_END()
+{
+ dSP;
+ SV* ret;
+ int count;
+ ENTER;
+ SAVETMPS;
+ PUSHMARK(SP);
+ count = call_pv("Tk::MainWindow::IsParentProcess", G_SCALAR);
+ SPAGAIN;
+ if (count != 1) croak("Unexpected return value from IsParentProcess");
+ ret = POPs;
+ if (SvTRUE(ret)) {
+  Tcl_Finalize();
+ }
+ PUTBACK;
+ FREETMPS;
+ LEAVE;
+}
 
 MODULE = Tk    PACKAGE = Tk    PREFIX = pTk_
 
diff -up 'Tk-804.025_beta14/Event/t/basic.t' 
'Tk-804.025_beta14-perl5.8.3d/Event/t/basic.t'
Index: ./Event/t/basic.t
--- ./Event/t/basic.t   Thu Dec 11 21:21:36 2003
+++ ./Event/t/basic.t   Mon Feb  9 02:07:52 2004
@@ -1,3 +1,3 @@
 use Test::More (tests => 1);
-
+use Tk; # needed because of Tk::END
 use_ok('Tk::Event');
diff -up 'Tk-804.025_beta14/MANIFEST' 'Tk-804.025_beta14-perl5.8.3d/MANIFEST'
Index: ./MANIFEST
--- ./MANIFEST  Thu Jan 29 00:08:33 2004
+++ ./MANIFEST  Sun Feb  8 20:07:43 2004
@@ -1847,6 +1847,7 @@ t/fbox.t
 t/fileevent.t
 t/fileselect.t
 t/font.t
+t/fork.t
 t/geomgr.t
 t/iso8859-1.t
 t/JP.dat
diff -up 'Tk-804.025_beta14/Tk/MainWindow.pm' 
'Tk-804.025_beta14-perl5.8.3d/Tk/MainWindow.pm'
Index: ./Tk/MainWindow.pm
--- ./Tk/MainWindow.pm  Sat Dec 27 10:10:04 2003
+++ ./Tk/MainWindow.pm  Sun Feb  8 20:07:25 2004
@@ -151,9 +151,14 @@ sub Existing
  return @Windows;
 }
 
+sub IsParentProcess
+{
+ $pid == $$;
+}
+
 END
 {
- if ($pid == $$)
+ if (IsParentProcess())
   {
    foreach my $top (values %Windows)
     {
diff -up /dev/null 'Tk-804.025_beta14-perl5.8.3d/t/fork.t'
Index: ./t/fork.t
--- ./t/fork.t  Thu Jan  1 01:00:00 1970
+++ ./t/fork.t  Sun Feb  8 20:40:00 2004
@@ -0,0 +1,18 @@
+#!/usr/bin/perl -w
+
+use strict;
+use Test;
+use Tk;
+
+plan tests => 1;
+
+my $mw = tkinit;
+
+if (fork == 0) {
+    CORE::exit();
+}
+select undef, undef, undef, 0.2;
+$mw->update;
+ok(1);
+
+__END__
#### End of Patch data ####

#### ApplyPatch data follows ####
# Data version        : 1.0
# Date generated      : Mon Feb  9 02:07:58 2004
# Generated by        : makepatch 2.00_05
# Recurse directories : Yes
# v 'pTk/patchlevel.h' 934 1071174116 33056
# p 'Event/Event.xs' 30806 1076268316 0100440
# p 'Event/t/basic.t' 51 1076288872 0100440
# p 'MANIFEST' 48329 1076267263 0100440
# p 'Tk/MainWindow.pm' 5663 1076267245 0100444
# c 't/fork.t' 0 1076269200 0100775
#### End of ApplyPatch data ####

#### End of Patch kit [created: Mon Feb  9 02:07:58 2004] ####
#### Patch checksum: 112 2706 60311 ####
#### Checksum: 142 3705 13145 ####



-- 
Slaven Rezic - slaven@xxxxxxxx

    tkrevdiff - graphical display of diffs between revisions (RCS, CVS or SVN)
    http://ptktools.sourceforge.net/#tkrevdiff
-++**==--++**==--++**==--++**==--++**==--++**==--++**==
This message was posted through the Stanford campus mailing list
server.  If you wish to unsubscribe from this mailing list, send the
message body of "unsubscribe ptk" to majordomo@xxxxxxxxxxxxxxxxxx