File Coverage

open.xs
Criterion Covered Total %
statement 52 59 88.1
branch 38 82 46.3
condition n/a
subroutine n/a
pod n/a
total 90 141 63.8


line stmt bran cond sub pod time code
1             #include "EXTERN.h"
2             #include "perl.h"
3             #include "XSUB.h"
4             #include "ppport.h"
5              
6             #define SAVE_AND_REPLACE_PP_IF_UNSET(real_function, op_to_replace, overload_function, OP_replace_mutex) do {\
7             MUTEX_LOCK(&OP_replace_mutex);\
8             if (!real_function) {\
9             real_function = PL_ppaddr[op_to_replace];\
10             }\
11             if (PL_ppaddr[op_to_replace] != overload_function) {\
12             PL_ppaddr[op_to_replace] = overload_function;\
13             }\
14             else {\
15             /* Would be nice if we could warn here. */\
16             }\
17             MUTEX_UNLOCK(&OP_replace_mutex);\
18             } while (0)
19              
20             #define overload_open_die_with_xs_sub 1
21             #define overload_open_max_function_pointers 2
22             OP* (*stuff_array[overload_open_max_function_pointers])(pTHX);
23             /* Declare function pointers for OP's */
24             OP* (*real_pp_open)(pTHX) = NULL;
25             OP* (*real_pp_sysopen)(pTHX) = NULL;
26              
27             #define overload_open_max_args 99
28             #ifdef USE_ITHREADS
29             static perl_mutex OP_OPEN_replace_mutex;
30             static perl_mutex OP_SYSOPEN_replace_mutex;
31             #endif
32              
33             OP * (*real_pp_open)(pTHX);
34             OP * (*real_pp_sysopen)(pTHX);
35             SV * cached_hook_open = NULL;
36             SV * cached_hook_sysopen = NULL;
37             CV * cached_code_hook_open = NULL;
38             CV * cached_code_hook_sysopen = NULL;
39 15           bool overload_is_sysopen(char *opname) {
40 15           return strcmp(opname, "sysopen") == 0;
41             }
42 15           bool overload_is_open(char *opname) {
43 15           return strcmp(opname, "open") == 0;
44             }
45 15           void set_cached_hooks_for_op (char *opname, SV *hook, CV *code_hook) {
46 15 100         if (overload_is_open(opname)) {
47 10           cached_hook_open = hook;
48 10           cached_code_hook_open = code_hook;
49             }
50 15 100         if (overload_is_sysopen(opname)) {
51 5           cached_hook_sysopen = hook;
52 5           cached_code_hook_sysopen = code_hook;
53             }
54 15           }
55 16           OP * overload_allopen(char *opname, char *global, OP* (*real_pp_func)(pTHX)) {
56 16           SV *hook = get_sv(global, 0);
57             /* If the hook evaluates as false, we should just call the original
58             * function ( AKA overload::open->prehook_open() has not been called yet ) */
59 16 50         if ( !hook || !SvTRUE( hook ) ) {
    50          
    50          
    0          
    100          
    50          
    50          
    50          
    0          
    0          
    0          
    0          
    0          
    50          
    0          
    0          
    0          
    0          
    0          
    50          
60 3           set_cached_hooks_for_op(opname, NULL, NULL);
61 3           return real_pp_func(aTHXR);
62             }
63             /* Check to make sure we have a coderef */
64 13 50         if ( !SvROK( hook ) || SvTYPE( SvRV(hook) ) != SVt_PVCV ) {
    50          
65 0           set_cached_hooks_for_op(opname, NULL, NULL);
66 0           warn("override::open expected a code reference, but got something else");
67 0           return real_pp_func(aTHXR);
68             }
69             /* Get the CV* that the reference refers to */
70 13           CV* code_hook = (CV*) SvRV(hook);
71 13 100         if ( CvISXSUB( code_hook ) ) {
72             if ( overload_open_die_with_xs_sub )
73 1           die("overload::open error. Cowardly refusing to hook an XS sub into %s", opname);
74             return real_pp_func(aTHXR);
75             }
76             /* Found suitable hook. We can cache in now */
77 12           set_cached_hooks_for_op(opname, hook, code_hook);
78              
79             /* CvDEPTH > 0 that means our hook is calling OP_OPEN. This is ok
80             * just ensure we direct things to the original function */
81             /* calling on the cached allows us to check the depth for both of the code functions */
82 12 100         if (cached_code_hook_open) {
83 11 100         if ( 0 < CvDEPTH( cached_code_hook_open ) ) {
84 3           return real_pp_func(aTHXR);
85             }
86             }
87 9 100         if (cached_code_hook_sysopen) {
88 6 50         if ( 0 < CvDEPTH( cached_code_hook_sysopen ) ) {
89 0           return real_pp_func(aTHXR);
90             }
91             }
92             /* Once more for paranoia */
93 9 50         if ( 0 < CvDEPTH( code_hook ) ) {
94 0           return real_pp_func(aTHXR);
95             }
96 9           SV **sp = PL_stack_sp;
97 9           ENTER;
98             /* Save the temporaries stack */
99 9           SAVETMPS;
100             /* sp (stack pointer) is used by some macros we call below. mysp is *ours* */
101             /* Save the stack pointer location */
102 9           SV **mysp = PL_stack_sp;
103             /* Save the number of items (number of arguments) */
104 9 50         PUSHMARK(sp);
105 9           ssize_t myitems = *PL_markstack_ptr;
106 9 50         if (myitems < 0) {
107 0           DIE(aTHXR_ "panic: overload::open internal error. This should not happen.");
108             }
109 9 50         EXTEND(sp, myitems);
    50          
110             ssize_t c;
111 35 100         for ( c = 0; c < myitems; c++) {
112             /* We are going from last to first */
113 26           ssize_t i = myitems - 1 - c;
114 26           mPUSHs( newSVsv(*(mysp - i)) );
115             }
116             /* PL_stack_sp = sp */
117 9           PUTBACK; /* Closing bracket for XSUB arguments */
118 9           I32 count = call_sv( (SV*)code_hook, G_VOID | G_DISCARD|G_EVAL |G_KEEPERR);
119             /* G_VOID and G_DISCARD should cause us to not ask for any return
120             * arguments from the call. */
121 9 50         if (count) warn("call_sv was not supposed to get any arguments");
122             /* The purpose of the macro "SPAGAIN" is to refresh the local copy of
123             * the stack pointer. This is necessary because it is possible that
124             * the memory allocated to the Perl stack has been reallocated during
125             * the *call_pv* call */
126             /* sp = PL_stack_sp */
127 9           SPAGAIN;
128              
129             /* FREETMPS cleans up all stuff on the temporaries stack added since SAVETMPS was called */
130 9 50         FREETMPS;
131 9           LEAVE;
132 9           return real_pp_func(aTHXR);
133             }
134              
135 11           PP(pp_overload_open) {
136 11           return overload_allopen("open", "overload::open::GLOBAL_OPEN", real_pp_open);
137             }
138              
139 5           PP(pp_overload_sysopen) {
140 5           return overload_allopen("sysopen", "overload::open::GLOBAL_SYSOPEN",
141             real_pp_sysopen);
142             }
143              
144             MODULE = overload::open PACKAGE = overload::open PREFIX = overload_open_
145              
146             PROTOTYPES: ENABLE
147              
148             void
149             _test_xs_function(...)
150             CODE:
151 0           printf("running test xs function\n");
152              
153             void
154             _install_open()
155             CODE:
156             MUTEX_INIT(&OP_OPEN_replace_mutex);
157 5 50         SAVE_AND_REPLACE_PP_IF_UNSET(real_pp_open, OP_OPEN, Perl_pp_overload_open, OP_OPEN_replace_mutex);
    50          
158              
159             void
160             _install_sysopen()
161             CODE:
162             MUTEX_INIT(&OP_SYSOPEN_replace_mutex);
163 5 50         SAVE_AND_REPLACE_PP_IF_UNSET(real_pp_sysopen, OP_SYSOPEN, Perl_pp_overload_sysopen, OP_SYSOPEN_replace_mutex);
    50