File Coverage

C.xs
Criterion Covered Total %
statement 60 74 81.0
branch 22 32 68.7
condition n/a
subroutine n/a
pod n/a
total 82 106 77.3


line stmt bran cond sub pod time code
1             /*******************************************************************************
2             *
3             * MODULE: C.xs
4             *
5             ********************************************************************************
6             *
7             * DESCRIPTION: XS Interface for Convert::Binary::C Perl extension module
8             *
9             ********************************************************************************
10             *
11             * Copyright (c) 2002-2020 Marcus Holland-Moritz. All rights reserved.
12             * This program is free software; you can redistribute it and/or modify
13             * it under the same terms as Perl itself.
14             *
15             ********************************************************************************
16             *
17             * "All you have to do is to decide what you are going to do
18             * with the time that is given to you." -- Gandalf
19             *
20             *******************************************************************************/
21              
22              
23             /*===== GLOBAL INCLUDES ======================================================*/
24              
25             #define PERL_NO_GET_CONTEXT
26             #include
27             #include
28              
29             #define NO_XSLOCKS
30             #include
31              
32             #define NEED_newRV_noinc_GLOBAL
33             #define NEED_sv_2pv_nolen_GLOBAL
34             #include "ppport.h"
35              
36              
37             /*===== LOCAL INCLUDES =======================================================*/
38              
39             #include "util/ccattr.h"
40             #include "util/list.h"
41             #include "util/hash.h"
42             #include "ctlib/cterror.h"
43             #include "ctlib/fileinfo.h"
44             #include "ctlib/parser.h"
45              
46             #include "cbc/cbc.h"
47             #include "cbc/debug.h"
48             #include "cbc/hook.h"
49             #include "cbc/init.h"
50             #include "cbc/macros.h"
51             #include "cbc/member.h"
52             #include "cbc/object.h"
53             #include "cbc/option.h"
54             #include "cbc/pack.h"
55             #include "cbc/sourcify.h"
56             #include "cbc/tag.h"
57             #include "cbc/type.h"
58             #include "cbc/typeinfo.h"
59             #include "cbc/util.h"
60              
61              
62             /*===== DEFINES ==============================================================*/
63              
64             #ifndef PerlEnv_getenv
65             # define PerlEnv_getenv getenv
66             #endif
67              
68             #ifdef CBC_DEBUGGING
69              
70             #define DBG_CTXT_FMT "%s"
71              
72             #define DBG_CTXT_ARG (GIMME_V == G_VOID ? "0=" : \
73             (GIMME_V == G_SCALAR ? "$=" : \
74             (GIMME_V == G_ARRAY ? "@=" : \
75             "?=" \
76             )))
77              
78             #endif
79              
80             #define CBC_METHOD(name) const char * const method PERL_UNUSED_DECL = #name
81             #define CBC_METHOD_VAR const char * method PERL_UNUSED_DECL = ""
82             #define CBC_METHOD_SET(string) method = string
83              
84             #define CT_DEBUG_METHOD \
85             CT_DEBUG(MAIN, (DBG_CTXT_FMT XSCLASS "::%s", DBG_CTXT_ARG, method))
86              
87             #define CT_DEBUG_METHOD1(fmt, arg1) \
88             CT_DEBUG(MAIN, (DBG_CTXT_FMT XSCLASS "::%s( " fmt " )", \
89             DBG_CTXT_ARG, method, arg1))
90              
91             #define CT_DEBUG_METHOD2(fmt, arg1, arg2) \
92             CT_DEBUG(MAIN, (DBG_CTXT_FMT XSCLASS "::%s( " fmt " )", \
93             DBG_CTXT_ARG, method, arg1, arg2) )
94              
95             #define CHECK_PARSE_DATA \
96             STMT_START { \
97             if (!THIS->cpi.available) \
98             Perl_croak(aTHX_ "Call to %s without parse data", method); \
99             } STMT_END
100              
101             #define NEED_PARSE_DATA \
102             STMT_START { \
103             if (THIS->cpi.available) \
104             { \
105             if (!THIS->cpi.ready) \
106             update_parse_info(&THIS->cpi, &THIS->cfg); \
107             assert(THIS->cpi.ready); \
108             } \
109             } STMT_END
110              
111             #define WARN_VOID_CONTEXT \
112             WARN((aTHX_ "Useless use of %s in void context", method))
113              
114             #define CHECK_VOID_CONTEXT \
115             STMT_START { \
116             if (GIMME_V == G_VOID) \
117             { \
118             WARN_VOID_CONTEXT; \
119             XSRETURN_EMPTY; \
120             } \
121             } STMT_END
122              
123              
124             /*===== TYPEDEFS =============================================================*/
125              
126             /*===== STATIC FUNCTION PROTOTYPES ===========================================*/
127              
128             static void *ct_newstr(void);
129             static void ct_scatf(void *p, const char *f, ...);
130             static void ct_vscatf(void *p, const char *f, va_list *l);
131             static const char *ct_cstring(void *p, size_t *len);
132             static void ct_fatal(void *p) __attribute__((__noreturn__));
133              
134             static void handle_parse_errors(pTHX_ LinkedList stack);
135              
136              
137             /*===== EXTERNAL VARIABLES ===================================================*/
138              
139             /*===== GLOBAL VARIABLES =====================================================*/
140              
141             /*===== STATIC VARIABLES =====================================================*/
142              
143             static int gs_DisableParser;
144             static int gs_OrderMembers;
145              
146              
147             /*===== GLOBAL FUNCTIONS =====================================================*/
148              
149             /*******************************************************************************
150             *
151             * ROUTINE: CBC_malloc, CBC_calloc, CBC_realloc, CBC_free
152             *
153             * WRITTEN BY: Marcus Holland-Moritz ON: Feb 2005
154             * CHANGED BY: ON:
155             *
156             ********************************************************************************
157             *
158             * DESCRIPTION: Memory allocation routines for ucpp and util libs.
159             *
160             *******************************************************************************/
161              
162 3634503           void *CBC_malloc(size_t size)
163             {
164             void *p;
165 3634503           New(0, p, size, char);
166 3634503           return p;
167             }
168              
169 0           void *CBC_calloc(size_t count, size_t size)
170             {
171             void *p;
172 0           Newz(0, p, count*size, char);
173 0           return p;
174             }
175              
176 1355           void *CBC_realloc(void *p, size_t size)
177             {
178 1355           Renew(p, size, char);
179 1355           return p;
180             }
181              
182 3634503           void CBC_free(void *p)
183             {
184 3634503           Safefree(p);
185 3634503           }
186              
187              
188             /*===== STATIC FUNCTIONS =====================================================*/
189              
190             /*******************************************************************************
191             *
192             * ROUTINE: ct_*
193             *
194             * WRITTEN BY: Marcus Holland-Moritz ON: Mar 2002
195             * CHANGED BY: ON:
196             *
197             ********************************************************************************
198             *
199             * DESCRIPTION: These functions are used to build arbitrary strings within the
200             * ctlib routines and to provide an interface to perl's warn().
201             *
202             *******************************************************************************/
203              
204 204           static void *ct_newstr(void)
205             {
206             dTHX;
207 204           return (void *) newSVpvn("", 0);
208             }
209              
210 204           static void ct_destroy(void *p)
211             {
212             dTHX;
213 204           SvREFCNT_dec((SV*)p);
214 204           }
215              
216 118           static void ct_scatf(void *p, const char *f, ...)
217             {
218             dTHX;
219             va_list l;
220 118           va_start(l, f);
221 118           sv_vcatpvf((SV*)p, f, &l);
222 118           va_end(l);
223 118           }
224              
225 204           static void ct_vscatf(void *p, const char *f, va_list *l)
226             {
227             dTHX;
228 204           sv_vcatpvf((SV*)p, f, l);
229 204           }
230              
231 204           static const char *ct_cstring(void *p, size_t *len)
232             {
233             dTHX;
234             STRLEN l;
235 204 50         const char *s = SvPV((SV*)p, l);
236 204 50         if (len)
237 204           *len = (size_t) l;
238 204           return s;
239             }
240              
241 0           static void ct_fatal(void *p)
242             {
243             dTHX;
244 0           sv_2mortal((SV*)p);
245 0 0         fatal("%s", SvPV_nolen((SV*)p));
246             }
247              
248             /*******************************************************************************
249             *
250             * ROUTINE: handle_parse_errors
251             *
252             * WRITTEN BY: Marcus Holland-Moritz ON: Nov 2003
253             * CHANGED BY: ON:
254             *
255             ********************************************************************************
256             *
257             * DESCRIPTION:
258             *
259             * ARGUMENTS:
260             *
261             * RETURNS:
262             *
263             *******************************************************************************/
264              
265 20866           static void handle_parse_errors(pTHX_ LinkedList stack)
266             {
267             ListIterator ei;
268             CTLibError *perr;
269              
270 20881 100         LL_foreach(perr, ei, stack)
    100          
271             {
272 179           switch (perr->severity)
273             {
274             case CTES_ERROR:
275 164           Perl_croak(aTHX_ "%s", perr->string);
276             break;
277              
278             case CTES_WARNING:
279 15 50         if( PERL_WARNINGS_ON )
280 15           Perl_warn(aTHX_ "%s", perr->string);
281 15           break;
282              
283             default:
284 0           Perl_croak(aTHX_ "unknown severity [%d] for error: %s",
285 0           perr->severity, perr->string);
286             }
287             }
288 20702           }
289              
290              
291             /*===== XS FUNCTIONS =========================================================*/
292              
293             MODULE = Convert::Binary::C PACKAGE = Convert::Binary::C
294              
295             PROTOTYPES: ENABLE
296              
297             INCLUDE: xsubs/cbc.xs
298              
299             INCLUDE: xsubs/clone.xs
300              
301             INCLUDE: xsubs/clean.xs
302              
303             INCLUDE: xsubs/configure.xs
304              
305             INCLUDE: xsubs/include.xs
306              
307             INCLUDE: xsubs/parse.xs
308              
309             INCLUDE: xsubs/def.xs
310              
311             INCLUDE: xsubs/pack.xs
312              
313             INCLUDE: xsubs/sizeof.xs
314              
315             INCLUDE: xsubs/typeof.xs
316              
317             INCLUDE: xsubs/offsetof.xs
318              
319             INCLUDE: xsubs/member.xs
320              
321             INCLUDE: xsubs/tag.xs
322              
323             INCLUDE: xsubs/enum.xs
324              
325             INCLUDE: xsubs/compound.xs
326              
327             INCLUDE: xsubs/typedef.xs
328              
329             INCLUDE: xsubs/sourcify.xs
330              
331             INCLUDE: xsubs/initializer.xs
332              
333             INCLUDE: xsubs/dependencies.xs
334              
335             INCLUDE: xsubs/defined.xs
336              
337             INCLUDE: xsubs/macro.xs
338              
339             INCLUDE: xsubs/arg.xs
340              
341             INCLUDE: xsubs/feature.xs
342              
343             INCLUDE: xsubs/native.xs
344              
345              
346             ################################################################################
347             #
348             # FUNCTION: import
349             #
350             # WRITTEN BY: Marcus Holland-Moritz ON: Mar 2002
351             # CHANGED BY: ON:
352             #
353             ################################################################################
354             #
355             # DESCRIPTION: Handle global features, currently only debugging support.
356             #
357             # ARGUMENTS:
358             #
359             # RETURNS:
360             #
361             ################################################################################
362              
363             #define WARN_NO_DEBUGGING 0x00000001
364              
365             void
366             import(...)
367             PREINIT:
368             int i;
369             U32 wflags;
370              
371             CODE:
372 69           wflags = 0;
373              
374 69 100         if (items % 2 == 0)
375 1           Perl_croak(aTHX_ "You must pass an even number of module arguments");
376             else
377             {
378 72 100         for (i = 1; i < items; i += 2)
379             {
380 4 50         const char *opt = SvPV_nolen(ST(i));
381             #ifdef CBC_DEBUGGING
382             const char *arg = SvPV_nolen(ST(i+1));
383             #endif
384 4 100         if (strEQ(opt, "debug"))
385             {
386             #ifdef CBC_DEBUGGING
387             set_debug_options(aTHX_ arg);
388             #else
389 2           wflags |= WARN_NO_DEBUGGING;
390             #endif
391             }
392 2 50         else if (strEQ(opt, "debugfile"))
393             {
394             #ifdef CBC_DEBUGGING
395             set_debug_file(aTHX_ arg);
396             #else
397 2           wflags |= WARN_NO_DEBUGGING;
398             #endif
399             }
400             else
401 0           Perl_croak(aTHX_ "Invalid module option '%s'", opt);
402             }
403              
404 68 100         if (wflags & WARN_NO_DEBUGGING)
405 3           Perl_warn(aTHX_ XSCLASS " not compiled with debugging support");
406             }
407              
408             #undef WARN_NO_DEBUGGING
409              
410              
411             ################################################################################
412             #
413             # FUNCTION: __DUMP__
414             #
415             # WRITTEN BY: Marcus Holland-Moritz ON: Mar 2002
416             # CHANGED BY: ON:
417             #
418             ################################################################################
419             #
420             # DESCRIPTION: Internal function used for reference count checks.
421             #
422             # ARGUMENTS:
423             #
424             # RETURNS:
425             #
426             ################################################################################
427              
428             SV *
429             __DUMP__(val)
430             SV *val
431              
432             CODE:
433 0           RETVAL = newSVpvn("", 0);
434             #ifdef CBC_DEBUGGING
435             dump_sv(aTHX_ RETVAL, 0, val);
436             #else
437             (void) val;
438 0           Perl_croak(aTHX_ "__DUMP__ not enabled in non-debug version");
439             #endif
440              
441             OUTPUT:
442             RETVAL
443              
444              
445             ################################################################################
446             #
447             # BOOTCODE
448             #
449             # WRITTEN BY: Marcus Holland-Moritz ON: Mar 2002
450             # CHANGED BY: ON:
451             #
452             ################################################################################
453              
454             BOOT:
455             {
456             const char *str;
457             PrintFunctions f;
458 60           f.newstr = ct_newstr;
459 60           f.destroy = ct_destroy;
460 60           f.scatf = ct_scatf;
461 60           f.vscatf = ct_vscatf;
462 60           f.cstring = ct_cstring;
463 60           f.fatalerr = ct_fatal;
464 60           set_print_functions(&f);
465             #ifdef CBC_DEBUGGING
466             init_debugging(aTHX);
467             if ((str = PerlEnv_getenv("CBC_DEBUG_OPT")) != NULL)
468             set_debug_options(aTHX_ str);
469             if ((str = PerlEnv_getenv("CBC_DEBUG_FILE")) != NULL)
470             set_debug_file(aTHX_ str);
471             #endif
472 60           gs_DisableParser = 0;
473 60 100         if ((str = PerlEnv_getenv("CBC_DISABLE_PARSER")) != NULL)
474 1           gs_DisableParser = atoi(str);
475 60           gs_OrderMembers = 0;
476 60 100         if ((str = PerlEnv_getenv("CBC_ORDER_MEMBERS")) != NULL)
477             {
478 1 50         if (isDIGIT(str[0]))
479 1           gs_OrderMembers = atoi(str);
480 0 0         else if (isALPHA(str[0]))
481             {
482 0           gs_OrderMembers = 1;
483 0           set_preferred_indexed_hash_module(str);
484             }
485             }
486             }