develooper Front page | perl.perl5.porters | Postings from August 2001

[PATCH] Adding callbacks to the core

Thread Next
From:
David M. Lloyd
Date:
August 21, 2001 08:50
Subject:
[PATCH] Adding callbacks to the core
Message ID:
Pine.LNX.4.33.0108211044100.1027-100000@homebody.freemm.org
Here's the patches necessary to add C callbacks to the core.  Per your
suggestions, I have rolled the callback check into the signal check code.

All tests pass on RH Linux 7.1 and Solaris 2.8.

Patches are against 11709.

Please send me your comments/abuse.

- D

<dmlloyd@tds.net>

---------- Forwarded message ----------
Date: Tue, 21 Aug 2001 10:42:40 -0500
From: Dave Lloyd <usrodl@tomservo.workpc.tds.net>

--- perl-current/perl.c	Fri Aug 17 00:24:14 2001
+++ perl-devel/perl.c	Mon Aug 20 17:56:58 2001
@@ -230,6 +230,8 @@
 	(void)PerlIO_close(PerlIO_importFILE(stdprn, 0));
 #endif
     }
+
+    MUTEX_INIT(&PL_callback_mutex);

     PL_nrs = newSVpvn("\n", 1);
     PL_rs = SvREFCNT_inc(PL_nrs);
@@ -830,6 +832,8 @@
     Safefree(PL_reentrant_buffer->tmbuff);
     Safefree(PL_reentrant_buffer);
 #endif
+
+    MUTEX_DESTROY(&PL_callback_mutex);

     sv_free_arenas();

--- perl-current/embed.pl	Fri Aug 17 00:24:14 2001
+++ perl-devel/embed.pl	Mon Aug 20 18:17:37 2001
@@ -2623,6 +2623,10 @@
 Apd	|char*	|sv_pvn_force_flags|SV* sv|STRLEN* lp|I32 flags
 Apd	|char*	|sv_2pv_flags	|SV* sv|STRLEN* lp|I32 flags
 Ap	|char*	|my_atof2	|const char *s|NV* value
+Apd	|CALLBACK * |register_callback	|void (*callback)(void *data)
+Apd	|void	    |enable_callback    |CALLBACK *cbptr|void *data
+Apd	|void	    |disable_callback   |CALLBACK *cbptr
+Apd	|void	    |free_callback  	|CALLBACK *cbptr

 END_EXTERN_C

--- perl-current/mg.c	Sat Aug 18 10:30:25 2001
+++ perl-devel/mg.c	Tue Aug 21 08:53:46 2001
@@ -1047,6 +1047,8 @@
     PL_psig_pend[sig]++;
     /* And one to say _a_ signal is pending */
     PL_sig_pending = 1;
+    /* And finally a flag to say that an event is pending */
+    PL_event_pending = 1;
 }

 Signal_t
@@ -1061,17 +1063,126 @@
 #endif
 }

+/* Maybe despatch_signals isn't a good name anymore */
+
 void
 Perl_despatch_signals(pTHX)
 {
-    int sig;
-    PL_sig_pending = 0;
-    for (sig = 1; sig < SIG_SIZE; sig++) {
-	if (PL_psig_pend[sig]) {
-	    PL_psig_pend[sig] = 0;
-	    (*PL_sighandlerp)(sig);
+    PL_event_pending = 0;
+    if (PL_sig_pending) {
+	int sig;
+	PL_sig_pending = 0;
+	for (sig = 1; sig < SIG_SIZE; sig++) {
+	    if (PL_psig_pend[sig]) {
+		PL_psig_pend[sig] = 0;
+		(*PL_sighandlerp)(sig);
+	    }
+	}
+    }
+    if (PL_callback_head != NULL) {
+	CALLBACK *cur, *next;
+
+        for (cur = PL_callback_head; cur != NULL; cur = next) {
+            next = cur->next;
+            (*cur->callback)(cur->data);
+        }
+    }
+}
+
+/*
+=for apidoc register_callback
+
+Register a callback that can be enabled via C<enable_callback>.  This
+can be called at any time.
+
+=cut
+*/
+CALLBACK *
+Perl_register_callback(pTHX_ void (*callback)(void *))
+{
+    CALLBACK *cbptr;
+    New(0,cbptr,1,CALLBACK);
+    cbptr->next = NULL;
+    cbptr->prev = NULL;
+    cbptr->callback = callback;
+    return cbptr;
+}
+
+/*
+=for apidoc enable_callback
+
+Enable a callback previously registered with C<register_callback>.  The
+callback will be called in between every opcode from then on until
+B<disable_callback> or B<free_callback> is called.  This can be called
+at any time.  If the callback is already enabled, it will remain enabled
+but the I<data> parameter will be updated.
+
+=cut
+*/
+void
+Perl_enable_callback(pTHX_ CALLBACK *cbptr, void *data)
+{
+    MUTEX_LOCK(&PL_callback_mutex);
+
+    cbptr->data = data;
+    if (! cbptr->enabled) {
+	if (PL_callback_head != NULL) {
+            PL_callback_head->prev = cbptr;
 	}
+	cbptr->next = PL_callback_head;
+	cbptr->prev = NULL;
+	PL_callback_head = cbptr;
+	cbptr->enabled = 1;
     }
+
+    MUTEX_UNLOCK(&PL_callback_mutex);
+}
+
+/*
+=for apidoc disable_callback
+
+Disable a previously registered callback.  If the callback is not enabled,
+does nothing.
+
+=cut
+*/
+
+void
+Perl_disable_callback(pTHX_ CALLBACK *cbptr)
+{
+    MUTEX_LOCK(&PL_callback_mutex);
+
+    if (cbptr->enabled) {
+	if (PL_callback_head == cbptr) {
+            PL_callback_head = cbptr->next;
+	}
+	if (cbptr->prev != NULL) {
+            cbptr->prev->next = cbptr->next;
+	}
+	if (cbptr->next != NULL) {
+            cbptr->next->prev = cbptr->prev;
+	}
+	cbptr->next = cbptr->prev = NULL;
+	cbptr->enabled = 0;
+    }
+
+    MUTEX_UNLOCK(&PL_callback_mutex);
+}
+
+/*
+=for apidoc free_callback
+
+Free resources associated with a callback.  If the callback is enabled, it
+will be disabled.
+
+=cut
+*/
+
+void
+Perl_free_callback(pTHX_ CALLBACK *cbptr)
+{
+    Perl_disable_callback(aTHX_ cbptr);
+    Safefree(cbptr);
 }

 int
--- perl-current/perl.h	Sat Aug 18 10:40:29 2001
+++ perl-devel/perl.h	Mon Aug 20 18:10:29 2001
@@ -1693,6 +1693,18 @@

 #endif

+/* Callback structure */
+
+struct perl_callback {
+    struct perl_callback *next;
+    struct perl_callback *prev;
+    int enabled;
+    void (*callback)(void *);
+    void *data;
+};
+
+typedef struct perl_callback CALLBACK;
+
 struct perl_mstats {
     UV *nfree;
     UV *ntotal;
@@ -3846,7 +3858,7 @@
 #ifndef PERL_MICRO
 #   ifndef PERL_OLD_SIGNALS
 #		ifndef PERL_ASYNC_CHECK
-#			define PERL_ASYNC_CHECK() if (PL_sig_pending) despatch_signals()
+#			define PERL_ASYNC_CHECK() if (PL_event_pending) despatch_signals()
 #		endif
 #   endif
 #endif
--- perl-current/intrpvar.h	Sat Aug 18 10:30:25 2001
+++ perl-devel/intrpvar.h	Mon Aug 20 17:54:49 2001
@@ -487,6 +487,13 @@

 PERLVAR(Isavebegin,     bool)	/* save BEGINs for compiler	*/

+PERLVARI(Icallback_head, CALLBACK *, NULL)  /* Pointer to first waiting callback */
+PERLVARI(Ievent_pending, int, 0)    	    /* Flag that indicates that an event is pending */
+
+#if defined(USE_THREADS) || defined(USE_ITHREADS)
+PERLVAR(Icallback_mutex, perl_mutex)	/* Mutex for adding callbacks in a threadsafe manner */
+#endif
+
 /* New variables must be added to the very end for binary compatibility.
  * XSUB.h provides wrapper functions via perlapi.h that make this
  * irrelevant, but not all code may be expected to #include XSUB.h. */


Thread Next


nntp.perl.org: Perl Programming lists via nntp and http.
Comments to Ask Bjørn Hansen at ask@perl.org | Group listing | About