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 <EXTERN.h>
27 #include <perl.h>
28
29 #define NO_XSLOCKS
30 #include <XSUB.h>
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
CBC_malloc(size_t size)162 void *CBC_malloc(size_t size)
163 {
164 void *p;
165 New(0, p, size, char);
166 return p;
167 }
168
CBC_calloc(size_t count,size_t size)169 void *CBC_calloc(size_t count, size_t size)
170 {
171 void *p;
172 Newz(0, p, count*size, char);
173 return p;
174 }
175
CBC_realloc(void * p,size_t size)176 void *CBC_realloc(void *p, size_t size)
177 {
178 Renew(p, size, char);
179 return p;
180 }
181
CBC_free(void * p)182 void CBC_free(void *p)
183 {
184 Safefree(p);
185 }
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
ct_newstr(void)204 static void *ct_newstr(void)
205 {
206 dTHX;
207 return (void *) newSVpvn("", 0);
208 }
209
ct_destroy(void * p)210 static void ct_destroy(void *p)
211 {
212 dTHX;
213 SvREFCNT_dec((SV*)p);
214 }
215
ct_scatf(void * p,const char * f,...)216 static void ct_scatf(void *p, const char *f, ...)
217 {
218 dTHX;
219 va_list l;
220 va_start(l, f);
221 sv_vcatpvf((SV*)p, f, &l);
222 va_end(l);
223 }
224
ct_vscatf(void * p,const char * f,va_list * l)225 static void ct_vscatf(void *p, const char *f, va_list *l)
226 {
227 dTHX;
228 sv_vcatpvf((SV*)p, f, l);
229 }
230
ct_cstring(void * p,size_t * len)231 static const char *ct_cstring(void *p, size_t *len)
232 {
233 dTHX;
234 STRLEN l;
235 const char *s = SvPV((SV*)p, l);
236 if (len)
237 *len = (size_t) l;
238 return s;
239 }
240
ct_fatal(void * p)241 static void ct_fatal(void *p)
242 {
243 dTHX;
244 sv_2mortal((SV*)p);
245 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
handle_parse_errors(pTHX_ LinkedList stack)265 static void handle_parse_errors(pTHX_ LinkedList stack)
266 {
267 ListIterator ei;
268 CTLibError *perr;
269
270 LL_foreach(perr, ei, stack)
271 {
272 switch (perr->severity)
273 {
274 case CTES_ERROR:
275 Perl_croak(aTHX_ "%s", perr->string);
276 break;
277
278 case CTES_WARNING:
279 if( PERL_WARNINGS_ON )
280 Perl_warn(aTHX_ "%s", perr->string);
281 break;
282
283 default:
284 Perl_croak(aTHX_ "unknown severity [%d] for error: %s",
285 perr->severity, perr->string);
286 }
287 }
288 }
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 wflags = 0;
373
374 if (items % 2 == 0)
375 Perl_croak(aTHX_ "You must pass an even number of module arguments");
376 else
377 {
378 for (i = 1; i < items; i += 2)
379 {
380 const char *opt = SvPV_nolen(ST(i));
381 #ifdef CBC_DEBUGGING
382 const char *arg = SvPV_nolen(ST(i+1));
383 #endif
384 if (strEQ(opt, "debug"))
385 {
386 #ifdef CBC_DEBUGGING
387 set_debug_options(aTHX_ arg);
388 #else
389 wflags |= WARN_NO_DEBUGGING;
390 #endif
391 }
392 else if (strEQ(opt, "debugfile"))
393 {
394 #ifdef CBC_DEBUGGING
395 set_debug_file(aTHX_ arg);
396 #else
397 wflags |= WARN_NO_DEBUGGING;
398 #endif
399 }
400 else
401 Perl_croak(aTHX_ "Invalid module option '%s'", opt);
402 }
403
404 if (wflags & WARN_NO_DEBUGGING)
405 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 RETVAL = newSVpvn("", 0);
434 #ifdef CBC_DEBUGGING
435 dump_sv(aTHX_ RETVAL, 0, val);
436 #else
437 (void) val;
438 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 f.newstr = ct_newstr;
459 f.destroy = ct_destroy;
460 f.scatf = ct_scatf;
461 f.vscatf = ct_vscatf;
462 f.cstring = ct_cstring;
463 f.fatalerr = ct_fatal;
464 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 gs_DisableParser = 0;
473 if ((str = PerlEnv_getenv("CBC_DISABLE_PARSER")) != NULL)
474 gs_DisableParser = atoi(str);
475 gs_OrderMembers = 0;
476 if ((str = PerlEnv_getenv("CBC_ORDER_MEMBERS")) != NULL)
477 {
478 if (isDIGIT(str[0]))
479 gs_OrderMembers = atoi(str);
480 else if (isALPHA(str[0]))
481 {
482 gs_OrderMembers = 1;
483 set_preferred_indexed_hash_module(strdup(str));
484 }
485 }
486 }
487