File Coverage

blib/lib/autobless.pm
Criterion Covered Total %
statement 3 3 100.0
branch n/a
condition n/a
subroutine 1 1 100.0
pod n/a
total 4 4 100.0


line stmt bran cond sub pod time code
1             package autobless;
2             $VERSION = '1.0.1';
3              
4 1     1   484 use base pragmatic;
  1         2  
  1         821  
5             bootstrap xsub;
6              
7             use xsub q{
8             static bool active = FALSE;
9              
10             static void filter(SV *rv) {
11             SV *sv;
12             if (!SvROK(rv) || SvREADONLY(sv = SvRV(rv)) || SvOBJECT(sv))
13             return;
14             sv_bless(rv, gv_stashpv(sv_reftype(sv, TRUE), TRUE));
15             }
16              
17             static OP *(*old_pp_srefgen)(pTHX) = NULL;
18             static OP *(*old_pp_refgen)(pTHX) = NULL;
19              
20             static OP *new_pp_srefgen(pTHX) {
21             OP *op;
22             op = old_pp_srefgen(aTHX);
23             filter(*(SV **)PL_stack_sp);
24             return op;
25             }
26              
27             static OP *new_pp_refgen(pTHX) {
28             register SV **mark = (GIMME == G_ARRAY) ?
29             PL_stack_base + *PL_markstack_ptr :
30             PL_stack_sp - 1;
31             OP *op = old_pp_refgen(aTHX);
32             while (++mark <= PL_stack_sp)
33             filter(*(SV **)mark);
34             return op;
35             }
36             };
37              
38             use xsub enable => q($), q{
39             if (active)
40             return &PL_sv_yes;
41              
42             old_pp_srefgen = PL_ppaddr[OP_SREFGEN];
43             PL_ppaddr[OP_SREFGEN] = new_pp_srefgen;
44             old_pp_refgen = PL_ppaddr[OP_REFGEN];
45             PL_ppaddr[OP_REFGEN] = new_pp_refgen;
46              
47             active = TRUE;
48             return &PL_sv_yes;
49             };
50              
51             use xsub disable => q($), q{
52             if (!active)
53             return &PL_sv_yes;
54              
55             active = FALSE;
56              
57             if (PL_ppaddr[OP_REFGEN] == new_pp_refgen) {
58             PL_ppaddr[OP_REFGEN] = old_pp_refgen;
59             } else {
60             Perl_warn(aTHX_ "PL_ppaddr[OP_REFGEN] apparently hijacked at %s line %d\n",
61             __FILE__, __LINE__);
62             }
63              
64             if (PL_ppaddr[OP_SREFGEN] == new_pp_srefgen) {
65             PL_ppaddr[OP_SREFGEN] = old_pp_srefgen;
66             } else {
67             Perl_warn(aTHX_ "PL_ppaddr[OP_SREFGEN] apparently hijacked at %s line %d\n",
68             __FILE__, __LINE__);
69             }
70             return &PL_sv_no;
71             };
72              
73             1