[Jifty-commit] r5357 - in Runops-Hook/trunk: . lib/Runops t
Jifty commits
jifty-commit at lists.jifty.org
Tue May 6 16:23:23 EDT 2008
Author: nothingmuch
Date: Tue May 6 16:23:23 2008
New Revision: 5357
Added:
Runops-Hook/trunk/Hook.xs
Runops-Hook/trunk/Makefile.PL
Runops-Hook/trunk/lib/
Runops-Hook/trunk/lib/Runops/
Runops-Hook/trunk/lib/Runops/Hook.pm
Runops-Hook/trunk/t/
Runops-Hook/trunk/t/01compile.t
Runops-Hook/trunk/t/02mapstart.t
Runops-Hook/trunk/t/03given.t
Runops-Hook/trunk/t/04features.t
Runops-Hook/trunk/t/05printtofh.t
Runops-Hook/trunk/t/06counters.t
Log:
initial version
Added: Runops-Hook/trunk/Hook.xs
==============================================================================
--- (empty file)
+++ Runops-Hook/trunk/Hook.xs Tue May 6 16:23:23 2008
@@ -0,0 +1,122 @@
+#define PERL_NO_GET_CONTEXT
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+bool (*Runops_Hook_hook)(pTHX);
+
+static HV *Runops_Hook_op_counters;
+
+static bool Runops_Hook_enabled = 0;
+static UV Runops_Hook_threshold = 0;
+
+int runops_hooked(pTHX)
+{
+ if ( !Runops_Hook_op_counters )
+ Runops_Hook_op_counters = newHV();
+
+ for (;PL_op;) {
+ if (Runops_Hook_enabled) {
+ if (Runops_Hook_threshold == 0) {
+ if (Runops_Hook_hook(aTHX))
+ continue;
+ } else {
+ SV **count = hv_fetch(Runops_Hook_op_counters, (char *)&PL_op, sizeof(PL_op), 1);
+ UV c = SvTRUE(*count) ? SvUV(*count) + 1 : 1;
+ sv_setuv(*count, c);
+
+ if (c >= Runops_Hook_threshold)
+ if (Runops_Hook_hook(aTHX))
+ continue;
+ }
+ }
+
+ PL_op = CALL_FPTR(PL_op->op_ppaddr)(aTHX);
+
+ PERL_ASYNC_CHECK();
+ }
+
+ TAINT_NOT;
+
+ return 0;
+}
+
+bool
+Runops_Hook_noop (pTHX) {
+ /* resume normally */
+ return 0;
+}
+
+void
+Runops_Hook_clear_hook () {
+ Runops_Hook_hook = Runops_Hook_noop;
+}
+
+void
+Runops_Hook_set_hook (bool (*hook)(pTHX)) {
+ Runops_Hook_hook = hook;
+}
+
+void
+Runops_Hook_enable () {
+ Runops_Hook_enabled = 1;
+}
+
+void
+Runops_Hook_disable () {
+ Runops_Hook_enabled = 0;
+}
+
+MODULE = Runops::Hook PACKAGE = Runops::Hook
+
+BOOT:
+ Runops_Hook_clear_hook();
+ PL_runops = runops_hooked;
+
+HV *
+counters()
+ CODE:
+{
+ RETVAL = Runops_Hook_op_counters;
+}
+ OUTPUT:
+ RETVAL
+
+bool
+enabled()
+ CODE:
+{
+ RETVAL = Runops_Hook_enabled;
+}
+ OUTPUT:
+ RETVAL
+
+void
+enable()
+ CODE:
+{
+ Runops_Hook_enable();
+}
+
+void
+disable()
+ CODE:
+{
+ Runops_Hook_disable();
+}
+
+UV
+get_threshold()
+ CODE:
+{
+ RETVAL = Runops_Hook_threshold;
+}
+ OUTPUT:
+ RETVAL
+
+void
+set_threshold(SV *a)
+ CODE:
+{
+ Runops_Hook_threshold = SvUV(a);
+}
Added: Runops-Hook/trunk/Makefile.PL
==============================================================================
--- (empty file)
+++ Runops-Hook/trunk/Makefile.PL Tue May 6 16:23:23 2008
@@ -0,0 +1,10 @@
+#!perl -w
+
+use 5.008;
+use strict;
+use ExtUtils::MakeMaker;
+
+WriteMakefile(
+ NAME => 'Runops::Hook',
+ VERSION_FROM => 'lib/Runops/Hook.pm',
+);
Added: Runops-Hook/trunk/lib/Runops/Hook.pm
==============================================================================
--- (empty file)
+++ Runops-Hook/trunk/lib/Runops/Hook.pm Tue May 6 16:23:23 2008
@@ -0,0 +1,63 @@
+package Runops::Hook;
+
+use strict;
+use warnings;
+
+our $VERSION = '0.01';
+
+use DynaLoader ();
+our @ISA = qw(DynaLoader);
+__PACKAGE__->bootstrap;
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+Runops::Hook - C level hooking of the runloop
+
+=head1 SYNOPSIS
+
+ # in MyHook.xs
+ bool
+ my_hook (pTHX) {
+ /* you can play with PL_op here */
+
+ /* returning a true value will skip the pp_addr call,
+ * letting the hook override the whole runloop */
+
+ return 0; /* resume the loop normally */
+ }
+
+ MODULE = MyHook PACKAGE MyHook
+ BOOT:
+ Runops_Hook_set_hook(my_hook);
+ Runops_Hook_enable();
+
+=head1 HOOKS
+
+The runloop has a global boolean, C<Runops_Hook_enabled>. When unset, the
+runloop works like the normal Perl run loop.
+
+When the flag is enabled and C<Runops_Hook_threshold> is 0 (the default) then
+the hook will be called on every loop iteration.
+
+If C<Runops_Hook_threshold> is set to a non zero value then the hook will only
+be called when an op counter C<PL_op> has reached the threshold.
+
+=head1 AUTHOR
+
+Chia-Liang Kao E<lt>clkao at clkao.orgE<gt>
+
+Yuval Kogman E<lt>nothingmuch at woobling.orgE<gt>
+
+=head1 COPYRIGHT
+
+ Copyright (c) 2008 Chia-Liang Kao, Yuval Kogman. All rights
+ reserved. This program is free software; you can redistribute
+ it and/or modify it under the same terms as Perl itself.
+
+=cut
Added: Runops-Hook/trunk/t/01compile.t
==============================================================================
--- (empty file)
+++ Runops-Hook/trunk/t/01compile.t Tue May 6 16:23:23 2008
@@ -0,0 +1,10 @@
+#!perl
+
+use Test::More tests => 4;
+
+use_ok('Runops::Hook');
+Runops::Hook::enable();
+
+pass('and it continues to work');
+eval { pass('... in eval {}') };
+eval q{ pass('... in eval STRING') };
Added: Runops-Hook/trunk/t/02mapstart.t
==============================================================================
--- (empty file)
+++ Runops-Hook/trunk/t/02mapstart.t Tue May 6 16:23:23 2008
@@ -0,0 +1,8 @@
+#!perl
+
+use Runops::Hook;
+BEGIN { Runops::Hook::enable() }
+
+use Test::More tests => 1;
+
+map { pass('map works') } '';
Added: Runops-Hook/trunk/t/03given.t
==============================================================================
--- (empty file)
+++ Runops-Hook/trunk/t/03given.t Tue May 6 16:23:23 2008
@@ -0,0 +1,26 @@
+#!perl
+
+use strict;
+use warnings;
+
+use Runops::Hook;
+BEGIN { Runops::Hook::enable() }
+
+use Test::More;
+
+BEGIN {
+ if ($] < 5.010) {
+ plan skip_all => "Requires 5.10";
+ exit(0);
+ }
+ else {
+ plan tests => 2;
+ }
+}
+
+use feature 'switch';
+
+given (42) {
+ pass("given works");
+ when (42) { pass("when works"); }
+}
Added: Runops-Hook/trunk/t/04features.t
==============================================================================
--- (empty file)
+++ Runops-Hook/trunk/t/04features.t Tue May 6 16:23:23 2008
@@ -0,0 +1,25 @@
+#!perl
+
+use strict;
+use warnings;
+
+use Runops::Hook;
+BEGIN { Runops::Hook::enable() }
+
+use Test::More;
+
+BEGIN {
+ if ($] < 5.010) {
+ plan skip_all => "Requires 5.10";
+ exit(0);
+ }
+ else {
+ plan tests => 2;
+ }
+}
+
+use feature qw(say state);
+
+state $foo = 42;
+say "# $foo" and pass("say returns 1");
+is($foo, 42);
Added: Runops-Hook/trunk/t/05printtofh.t
==============================================================================
--- (empty file)
+++ Runops-Hook/trunk/t/05printtofh.t Tue May 6 16:23:23 2008
@@ -0,0 +1,13 @@
+#!perl
+
+use strict;
+use warnings;
+use Runops::Hook;
+BEGIN { Runops::Hook::enable() }
+
+use Test::More tests => 1;
+
+# this segfaults when loading PerlIO::scalar
+open my $tmp, '>', \my $out;
+print $tmp "foo";
+is($out, "foo", "print to PerlIO::scalar works");
Added: Runops-Hook/trunk/t/06counters.t
==============================================================================
--- (empty file)
+++ Runops-Hook/trunk/t/06counters.t Tue May 6 16:23:23 2008
@@ -0,0 +1,25 @@
+#!perl
+
+use strict;
+use warnings;
+
+use Runops::Hook;
+use Test::More 'no_plan';
+
+ok( !Runops::Hook::enabled(), "disabled" );
+
+is_deeply( Runops::Hook::counters(), {}, "no counters yet" );
+
+Runops::Hook::enable();
+ok( Runops::Hook::enabled(), "enabled" );
+
+Runops::Hook::set_threshold(3);
+
+my $i;
+for ( 1 .. 10 ) {
+ $i++;
+}
+
+is( $i, 10, "loop ran correctly" );
+
+ok( scalar(keys %{ Runops::Hook::counters() }), "counted something now" );
More information about the Jifty-commit
mailing list