1 /*
2 Copyright (C) 2001-2012, 2014-2020 Free Software Foundation, Inc.
3 Written by Keisuke Nishida, Roger While, Simon Sobisch, Ron Norman
4
5 This file is part of GnuCOBOL.
6
7 The GnuCOBOL runtime library is free software: you can redistribute it
8 and/or modify it under the terms of the GNU Lesser General Public License
9 as published by the Free Software Foundation, either version 3 of the
10 License, or (at your option) any later version.
11
12 GnuCOBOL is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU Lesser General Public License for more details.
16
17 You should have received a copy of the GNU Lesser General Public License
18 along with GnuCOBOL. If not, see <https://www.gnu.org/licenses/>.
19 */
20
21 #include <config.h>
22 #include <tarstamp.h>
23
24 #include <stdio.h>
25 #include <stdlib.h>
26 #include <stddef.h>
27 #include <stdarg.h>
28 #include <string.h>
29 #include <ctype.h>
30 #include <sys/types.h>
31 #include <sys/stat.h>
32 #include <errno.h>
33
34 #include <math.h>
35 #ifdef HAVE_FINITE_IEEEFP_H
36 #include <ieeefp.h>
37 #endif
38
39 #include <time.h>
40
41 #ifdef HAVE_UNISTD_H
42 #include <unistd.h>
43 #endif
44 #ifdef HAVE_SYS_TIME_H
45 #include <sys/time.h>
46 #endif
47 #ifdef HAVE_SYS_WAIT_H
48 #include <sys/wait.h>
49 #endif
50
51 #ifdef _WIN32
52 #define WIN32_LEAN_AND_MEAN
53 #include <windows.h>
54 #undef MOUSE_MOVED
55 #include <process.h>
56 #include <io.h>
57 #include <fcntl.h> /* for _O_BINARY only */
58 #endif
59
60 #ifdef HAVE_SIGNAL_H
61 #include <signal.h>
62 #endif
63
64 #ifdef HAVE_LOCALE_H
65 #include <locale.h>
66 #endif
67
68 /* library headers for version output */
69 #ifdef _WIN32
70 #ifndef __GMP_LIBGMP_DLL
71 #define __GMP_LIBGMP_DLL 1
72 #endif
73 #endif
74 #ifdef HAVE_GMP_H
75 #include <gmp.h>
76 #elif defined HAVE_MPIR_H
77 #include <mpir.h>
78 #else
79 #error either HAVE_GMP_H or HAVE_MPIR_H needs to be defined
80 #endif
81
82 #ifdef WITH_DB
83 #include <db.h>
84 #endif
85
86 #if defined (HAVE_NCURSESW_NCURSES_H)
87 #include <ncursesw/ncurses.h>
88 #define COB_GEN_SCREENIO
89 #elif defined (HAVE_NCURSESW_CURSES_H)
90 #include <ncursesw/curses.h>
91 #define COB_GEN_SCREENIO
92 #elif defined (HAVE_NCURSES_H)
93 #include <ncurses.h>
94 #define COB_GEN_SCREENIO
95 #elif defined (HAVE_NCURSES_NCURSES_H)
96 #include <ncurses/ncurses.h>
97 #define COB_GEN_SCREENIO
98 #elif defined (HAVE_PDCURSES_H)
99 /* will internally define NCURSES_MOUSE_VERSION with
100 a recent version (for older version define manually): */
101 #define PDC_NCMOUSE /* use ncurses compatible mouse API */
102 #include <pdcurses.h>
103 #define COB_GEN_SCREENIO
104 #elif defined (HAVE_CURSES_H)
105 #define PDC_NCMOUSE /* see comment above */
106 #include <curses.h>
107 #define COB_GEN_SCREENIO
108 #ifndef PDC_MOUSE_MOVED
109 #undef PDC_NCMOUSE
110 #endif
111 #endif
112
113 #if defined (WITH_XML2)
114 #include <libxml/xmlversion.h>
115 #include <libxml/xmlwriter.h>
116 #endif
117
118 #if defined (WITH_CJSON)
119 #if defined (HAVE_CJSON_CJSON_H)
120 #include <cjson/cJSON.h>
121 #elif defined (HAVE_CJSON_H)
122 #include <cJSON.h>
123 #else
124 #error CJSON without necessary header
125 #endif
126 #elif defined (WITH_JSON_C)
127 #include <json_c_version.h>
128 #endif
129
130 /* end of library headers */
131
132 #include "lib/gettext.h"
133
134 /* Force symbol exports */
135 #define COB_LIB_EXPIMP
136 #include "libcob.h"
137 #include "coblocal.h"
138
139 #include "libcob/cobgetopt.h"
140
141 /* sanity checks */
142 #if COB_MAX_WORDLEN > 255
143 #error COB_MAX_WORDLEN is too big, must be less than 256
144 #endif
145 #if COB_MAX_NAMELEN > COB_MAX_WORDLEN
146 #error COB_MAX_NAMELEN is too big, must be less than COB_MAX_WORDLEN
147 #endif
148
149 #define CB_IMSG_SIZE 24
150 #define CB_IVAL_SIZE (80 - CB_IMSG_SIZE - 4)
151
152 /* Stringify macros */
153 #define CB_STRINGIFY(s) #s
154 #define CB_XSTRINGIFY(s) CB_STRINGIFY (s)
155
156 /* C version info */
157 #ifdef __VERSION__
158 #if ! defined (_MSC_VER)
159 #if defined (__MINGW32__)
160 #define GC_C_VERSION_PRF "(MinGW) "
161 #elif defined (__DJGPP__)
162 #define GC_C_VERSION_PRF "(DJGPP) "
163 #elif defined (__ORANGEC__)
164 #define GC_C_VERSION_PRF "(OrangeC) "
165 #else
166 #define GC_C_VERSION_PRF ""
167 #endif
168 #elif defined (__c2__)
169 #define GC_C_VERSION_PRF "(Microsoft C2) "
170 #elif defined (__llvm__)
171 #define GC_C_VERSION_PRF "(LLVM / MSC) "
172 #else
173 #define GC_C_VERSION_PRF "(Microsoft) "
174 #endif
175 #define GC_C_VERSION CB_XSTRINGIFY (__VERSION__)
176 #elif defined (__xlc__)
177 #define GC_C_VERSION_PRF "(IBM XL C/C++) "
178 #define GC_C_VERSION CB_XSTRINGIFY (__xlc__)
179 #elif defined (__SUNPRO_C)
180 #define GC_C_VERSION_PRF "(Sun C) "
181 #define GC_C_VERSION CB_XSTRINGIFY (__SUNPRO_C)
182 #elif defined (_MSC_VER)
183 #define GC_C_VERSION_PRF "(Microsoft) "
184 #define GC_C_VERSION CB_XSTRINGIFY (_MSC_VER)
185 #elif defined (__BORLANDC__)
186 #define GC_C_VERSION_PRF "(Borland) "
187 #define GC_C_VERSION CB_XSTRINGIFY (__BORLANDC__)
188 #elif defined (__WATCOMC__)
189 #define GC_C_VERSION_PRF "(Watcom) "
190 #define GC_C_VERSION CB_XSTRINGIFY (__WATCOMC__)
191 #elif defined (__INTEL_COMPILER)
192 #define GC_C_VERSION_PRF "(Intel) "
193 #define GC_C_VERSION CB_XSTRINGIFY (__INTEL_COMPILER)
194 #elif defined(__TINYC__)
195 #define GC_C_VERSION_PRF "(Tiny C) "
196 #define GC_C_VERSION CB_XSTRINGIFY(__TINYC__)
197 #elif defined(__HP_cc)
198 #define GC_C_VERSION_PRF "(HP aC++/ANSI C) "
199 #define GC_C_VERSION CB_XSTRINGIFY(__HP_cc)
200 #elif defined(__hpux) || defined(_HPUX_SOURCE)
201 #if defined(__ia64)
202 #define GC_C_VERSION_PRF "(HPUX IA64) "
203 #else
204 #define GC_C_VERSION_PRF "(HPUX PA-RISC) "
205 #endif
206 #define GC_C_VERSION " C"
207 #else
208 #define GC_C_VERSION_PRF ""
209 #define GC_C_VERSION _("unknown")
210 #endif
211
212 #if COB_MAX_UNBOUNDED_SIZE > COB_MAX_FIELD_SIZE
213 #define COB_MAX_ALLOC_SIZE COB_MAX_UNBOUNDED_SIZE
214 #else
215 #define COB_MAX_ALLOC_SIZE COB_MAX_FIELD_SIZE
216 #endif
217
218 struct cob_alloc_cache {
219 struct cob_alloc_cache *next; /* Pointer to next */
220 void *cob_pointer; /* Pointer to malloced space */
221 size_t size; /* Item size */
222 };
223
224 struct cob_alloc_module {
225 struct cob_alloc_module *next; /* Pointer to next */
226 void *cob_pointer; /* Pointer to malloced space */
227 };
228
229 /* EXTERNAL structure */
230
231 struct cob_external {
232 struct cob_external *next; /* Pointer to next */
233 void *ext_alloc; /* Pointer to malloced space */
234 char *ename; /* External name */
235 int esize; /* Item size */
236 };
237
238 #define COB_ERRBUF_SIZE 1024
239
240 /* Local variables */
241
242 static int cob_initialized = 0;
243 static int check_mainhandle = 1;
244 static int cob_argc = 0;
245 static char **cob_argv = NULL;
246 static struct cob_alloc_cache *cob_alloc_base = NULL;
247 static struct cob_alloc_module *cob_module_list = NULL;
248 static cob_module *cob_module_err = NULL;
249 static const char *cob_last_sfile = NULL;
250 static const char *cob_last_progid = NULL;
251
252 static cob_global *cobglobptr = NULL;
253 static cob_settings *cobsetptr = NULL;
254
255 static int last_exception_code; /* Last exception: code */
256 static int active_error_handler = 0;
257 static char *runtime_err_str = NULL;
258
259 static int cannot_check_subscript = 0;
260
261 static const cob_field_attr const_alpha_attr =
262 {COB_TYPE_ALPHANUMERIC, 0, 0, 0, NULL};
263 static const cob_field_attr const_bin_nano_attr =
264 {COB_TYPE_NUMERIC_BINARY, 20, 9,
265 COB_FLAG_HAVE_SIGN, NULL};
266
267 static char *cob_local_env = NULL;
268 static int current_arg = 0;
269 static unsigned char *commlnptr = NULL;
270 static size_t commlncnt = 0;
271 static size_t cob_local_env_size = 0;
272
273 static struct cob_external *basext = NULL;
274
275 static size_t sort_nkeys = 0;
276 static cob_file_key *sort_keys = NULL;
277 static const unsigned char *sort_collate = NULL;
278
279 static const char *cob_current_program_id = NULL;
280 static const char *cob_current_section = NULL;
281 static const char *cob_current_paragraph = NULL;
282 static const char *cob_source_file = NULL;
283 static const char *cob_source_statement = NULL;
284 static unsigned int cob_source_line = 0;
285
286 #ifdef COB_DEBUG_LOG
287 static int cob_debug_log_time = 0;
288 static FILE *cob_debug_file = NULL;
289 static int cob_debug_level = 9;
290 static char *cob_debug_mod = NULL;
291 static char cob_debug_modules[12][4] = {"", "", "", "", "", "", "", "", "", "", "", ""};
292 static char *cob_debug_file_name = NULL;
293 #endif
294
295 static char *strbuff = NULL;
296
297 static int cob_process_id = 0;
298 static int cob_temp_iteration = 0;
299
300 static unsigned int conf_runtime_error_displayed = 0;
301 static unsigned int last_runtime_error_line = 0;
302 static const char *last_runtime_error_file = NULL;
303
304 #if defined (HAVE_SIGNAL_H) && defined (HAVE_SIG_ATOMIC_T)
305 static volatile sig_atomic_t sig_is_handled = 0;
306 #endif
307
308 /* Function Pointer for external signal handling */
309 static void (*cob_ext_sighdl) (int) = NULL;
310
311 #if defined (_MSC_VER) && COB_USE_VC2008_OR_GREATER
312 static VOID (WINAPI *time_as_filetime_func) (LPFILETIME) = NULL;
313 #endif
314
315 #undef COB_EXCEPTION
316 #define COB_EXCEPTION(code, tag, name, critical) name,
317 static const char * const cob_exception_tab_name[] = {
318 "None", /* COB_EC_ZERO */
319 #include "exception.def"
320 "Invalid" /* COB_EC_MAX */
321 };
322
323 #undef COB_EXCEPTION
324 #define COB_EXCEPTION(code, tag, name, critical) 0x##code,
325 static const int cob_exception_tab_code[] = {
326 0, /* COB_EC_ZERO */
327 #include "exception.def"
328 0 /* COB_EC_MAX */
329 };
330
331 #undef COB_EXCEPTION
332
333 #define EXCEPTION_TAB_SIZE sizeof (cob_exception_tab_code) / sizeof (int)
334
335 /* Switches */
336 #define COB_SWITCH_MAX 36 /* (must match cobc/tree.h)*/
337
338 static int cob_switch[COB_SWITCH_MAX + 1];
339
340 /* Runtime exit handling */
341 static struct exit_handlerlist {
342 struct exit_handlerlist *next;
343 int (*proc)(void);
344 unsigned char priority;
345 } *exit_hdlrs;
346
347 /* Runtime error handling */
348 static struct handlerlist {
349 struct handlerlist *next;
350 int (*proc)(char *s);
351 } *hdlrs;
352
353 /* note: set again (translated) in print_runtime_conf */
354 static const char *setting_group[] = {" hidden setting ", "CALL configuration",
355 "File I/O configuration", "Screen I/O configuration", "Miscellaneous",
356 "System configuration"};
357
358 static struct config_enum lwrupr[] = {{"LOWER", "1"}, {"UPPER", "2"}, {"not set", "0"}, {NULL, NULL}};
359 static struct config_enum beepopts[] = {{"FLASH", "1"}, {"SPEAKER", "2"}, {"FALSE", "9"}, {"BEEP", "0"}, {NULL, NULL}};
360 static struct config_enum timeopts[] = {{"0", "1000"}, {"1", "100"}, {"2", "10"}, {"3", "1"}, {NULL, NULL}};
361 static struct config_enum syncopts[] = {{"P", "1"}, {NULL, NULL}};
362 static struct config_enum varseqopts[] = {{"0", "0"}, {"1", "1"}, {"2", "2"}, {"3", "3"}, {NULL, NULL}};
363 static char varseq_dflt[8] = "0";
364 static unsigned char min_conf_length = 0;
365 static const char *not_set;
366
367 /*
368 * Table of possible environment variables and/or runtime.cfg parameters:
369 Env Var name, Name used in run-time config file, Default value (NULL for aliases), Table of Alternate values,
370 Grouping for display of run-time options, Data type, Location within structure (adds computed length of referenced field),
371 Set by which runtime.cfg file, value set by a different keyword,
372 optional: Minimum accepted value, Maximum accepted value
373 */
374 static struct config_tbl gc_conf[] = {
375 {"COB_LOAD_CASE", "load_case", "0", lwrupr, GRP_CALL, ENV_UINT | ENV_ENUMVAL, SETPOS (name_convert)},
376 {"COB_PHYSICAL_CANCEL", "physical_cancel", "0", NULL, GRP_CALL, ENV_BOOL, SETPOS (cob_physical_cancel)},
377 {"default_cancel_mode", "default_cancel_mode", NULL, NULL, GRP_HIDE, ENV_BOOL | ENV_NOT, SETPOS (cob_physical_cancel)},
378 {"LOGICAL_CANCELS", "logical_cancels", NULL, NULL, GRP_HIDE, ENV_BOOL | ENV_NOT, SETPOS (cob_physical_cancel)},
379 {"COB_PRE_LOAD", "pre_load", NULL, NULL, GRP_CALL, ENV_STR, SETPOS (cob_preload_str)},
380 {"COB_BELL", "bell", "0", beepopts, GRP_SCREEN, ENV_UINT | ENV_ENUMVAL, SETPOS (cob_beep_value)},
381 {"COB_DEBUG_LOG", "debug_log", NULL, NULL, GRP_HIDE, ENV_FILE, SETPOS (cob_debug_log)},
382 {"COB_DISABLE_WARNINGS", "disable_warnings", "0", NULL, GRP_MISC, ENV_BOOL | ENV_NOT, SETPOS (cob_display_warn)},
383 {"COB_ENV_MANGLE", "env_mangle", "0", NULL, GRP_MISC, ENV_BOOL, SETPOS (cob_env_mangle)},
384 {"COB_COL_JUST_LRC", "col_just_lrc", "true", NULL, GRP_MISC, ENV_BOOL, SETPOS (cob_col_just_lrc)},
385 {"COB_REDIRECT_DISPLAY", "redirect_display", "0", NULL, GRP_SCREEN, ENV_BOOL, SETPOS (cob_disp_to_stderr)},
386 {"COB_SCREEN_ESC", "screen_esc", "0", NULL, GRP_SCREEN, ENV_BOOL, SETPOS (cob_use_esc)},
387 {"COB_SCREEN_EXCEPTIONS", "screen_exceptions", "0", NULL, GRP_SCREEN, ENV_BOOL, SETPOS (cob_extended_status)},
388 {"COB_TIMEOUT_SCALE", "timeout_scale", "0", timeopts, GRP_SCREEN, ENV_UINT, SETPOS (cob_timeout_scale)},
389 {"COB_INSERT_MODE", "insert_mode", "0", NULL, GRP_SCREEN, ENV_BOOL, SETPOS (cob_insert_mode)},
390 {"COB_MOUSE_FLAGS", "mouse_flags", "1", NULL, GRP_SCREEN, ENV_UINT, SETPOS (cob_mouse_flags)},
391 {"MOUSE_FLAGS", "mouse_flags", NULL, NULL, GRP_HIDE, ENV_UINT, SETPOS (cob_mouse_flags)},
392 #ifdef HAVE_MOUSEINTERVAL /* possibly add an internal option for mouse support, too */
393 {"COB_MOUSE_INTERVAL", "mouse_interval", "100", NULL, GRP_SCREEN, ENV_UINT, SETPOS (cob_mouse_interval), 0, 166},
394 #endif
395 {"COB_SET_DEBUG", "debugging_mode", "0", NULL, GRP_MISC, ENV_BOOL | ENV_RESETS, SETPOS (cob_debugging_mode)},
396 {"COB_SET_TRACE", "set_trace", "0", NULL, GRP_MISC, ENV_BOOL, SETPOS (cob_line_trace)},
397 {"COB_TRACE_FILE", "trace_file", NULL, NULL, GRP_MISC, ENV_FILE, SETPOS (cob_trace_filename)},
398 {"COB_TRACE_FORMAT", "trace_format", "%P %S Line: %L", NULL,GRP_MISC, ENV_STR, SETPOS (cob_trace_format)},
399 {"COB_STACKTRACE", "stacktrace", "1", NULL, GRP_CALL, ENV_BOOL, SETPOS (cob_stacktrace)},
400 {"COB_DUMP_FILE", "dump_file", NULL, NULL, GRP_MISC, ENV_FILE, SETPOS (cob_dump_filename)},
401 {"COB_DUMP_WIDTH", "dump_width", "100", NULL, GRP_MISC, ENV_UINT, SETPOS (cob_dump_width)},
402 #ifdef _WIN32
403 /* checked before configuration load if set from environment in cob_common_init() */
404 {"COB_UNIX_LF", "unix_lf", "0", NULL, GRP_FILE, ENV_BOOL, SETPOS (cob_unix_lf)},
405 #endif
406 {"USERNAME", "username", NULL, NULL, GRP_SYSENV, ENV_STR, SETPOS (cob_user_name)}, /* default set in cob_init() */
407 {"LOGNAME", "logname", NULL, NULL, GRP_HIDE, ENV_STR, SETPOS (cob_user_name)},
408 #if !defined (_WIN32) || defined (__MINGW32__) /* cygwin does not define _WIN32 */
409 {"LANG", "lang", NULL, NULL, GRP_SYSENV, ENV_STR, SETPOS (cob_sys_lang)},
410 #if defined (__linux__) || defined (__CYGWIN__) || defined (__MINGW32__)
411 {"OSTYPE", "ostype", NULL, NULL, GRP_SYSENV, ENV_STR, SETPOS (cob_sys_type)},
412 #endif
413 {"TERM", "term", NULL, NULL, GRP_SYSENV, ENV_STR, SETPOS (cob_sys_term)},
414 #endif
415 #if defined (_WIN32) && !defined (__MINGW32__)
416 {"OS", "ostype", NULL, NULL, GRP_SYSENV, ENV_STR, SETPOS (cob_sys_type)},
417 #endif
418 {"COB_FILE_PATH", "file_path", NULL, NULL, GRP_FILE, ENV_PATH, SETPOS (cob_file_path)},
419 {"COB_LIBRARY_PATH", "library_path", NULL, NULL, GRP_CALL, ENV_PATH, SETPOS (cob_library_path)}, /* default value set in cob_init_call() */
420 {"COB_VARSEQ_FORMAT", "varseq_format", varseq_dflt, varseqopts, GRP_FILE, ENV_UINT | ENV_ENUM, SETPOS (cob_varseq_type)},
421 {"COB_LS_FIXED", "ls_fixed", "0", NULL, GRP_FILE, ENV_BOOL, SETPOS (cob_ls_fixed)},
422 {"STRIP_TRAILING_SPACES", "strip_trailing_spaces", NULL, NULL, GRP_HIDE, ENV_BOOL | ENV_NOT, SETPOS (cob_ls_fixed)},
423 {"COB_LS_NULLS", "ls_nulls", "0", NULL, GRP_FILE, ENV_BOOL, SETPOS (cob_ls_nulls)},
424 {"COB_SORT_CHUNK", "sort_chunk", "256K", NULL, GRP_FILE, ENV_SIZE, SETPOS (cob_sort_chunk), (128 * 1024), (16 * 1024 * 1024)},
425 {"COB_SORT_MEMORY", "sort_memory", "128M", NULL, GRP_FILE, ENV_SIZE, SETPOS (cob_sort_memory), (1024*1024), 4294967294 /* max. guaranteed - 1 */},
426 {"COB_SYNC", "sync", "0", syncopts, GRP_FILE, ENV_BOOL, SETPOS (cob_do_sync)},
427 #ifdef WITH_DB
428 {"DB_HOME", "db_home", NULL, NULL, GRP_FILE, ENV_FILE, SETPOS (bdb_home)},
429 #endif
430 {"COB_DISPLAY_PRINT_PIPE", "display_print_pipe", NULL, NULL, GRP_SCREEN, ENV_STR, SETPOS (cob_display_print_pipe)},
431 {"COBPRINTER", "printer", NULL, NULL, GRP_HIDE, ENV_STR, SETPOS (cob_display_print_pipe)},
432 {"COB_DISPLAY_PRINT_FILE", "display_print_file", NULL, NULL, GRP_SCREEN, ENV_STR,SETPOS (cob_display_print_filename)},
433 {"COB_DISPLAY_PUNCH_FILE", "display_punch_file", NULL, NULL, GRP_SCREEN, ENV_STR,SETPOS (cob_display_punch_filename)},
434 {"COB_LEGACY", "legacy", NULL, NULL, GRP_SCREEN, ENV_BOOL, SETPOS (cob_legacy)},
435 {"COB_EXIT_WAIT", "exit_wait", "1", NULL, GRP_SCREEN, ENV_BOOL, SETPOS (cob_exit_wait)},
436 {"COB_EXIT_MSG", "exit_msg", NULL, NULL, GRP_SCREEN, ENV_STR, SETPOS (cob_exit_msg)}, /* default set in cob_init_screenio() */
437 {"COB_CURRENT_DATE" ,"current_date", NULL, NULL, GRP_MISC, ENV_STR, SETPOS (cob_date)},
438 {"COB_DATE", "date", NULL, NULL, GRP_HIDE, ENV_STR, SETPOS (cob_date)},
439 {NULL, NULL, 0, 0}
440 };
441 #define NUM_CONFIG (sizeof (gc_conf) /sizeof (struct config_tbl) - 1)
442 #define FUNC_NAME_IN_DEFAULT NUM_CONFIG + 1
443
444 /* Local functions */
445 static int translate_boolean_to_int (const char* ptr);
446 static cob_s64_t get_sleep_nanoseconds (cob_field *nano_seconds);
447 static cob_s64_t get_sleep_nanoseconds_from_seconds (cob_field *decimal_seconds);
448 static void internal_nanosleep (cob_s64_t nsecs);
449
450 static int set_config_val (char *value, int pos);
451 static char *get_config_val (char *value, int pos, char *orgvalue);
452
453 static void cob_dump_module (char *reason);
454 static char abort_reason[COB_MINI_BUFF] = "";
455 static unsigned int dump_trace_started; /* ensures that we dump/stacktrace only once */
456 #define DUMP_TRACE_DONE_DUMP (1U << 0)
457 #define DUMP_TRACE_DONE_TRACE (1U << 1)
458 #define DUMP_TRACE_ACTIVE_TRACE (1U << 2)
459 static void cob_stack_trace_internal (FILE *target);
460
461 #ifdef COB_DEBUG_LOG
462 static void cob_debug_open (void);
463 #endif
464 void conf_runtime_error_value (const char *value, const int conf_pos);
465 void conf_runtime_error (const int finish_error, const char *fmt, ...);
466
467 static void
cob_exit_common(void)468 cob_exit_common (void)
469 {
470 struct cob_external *p;
471 struct cob_external *q;
472 struct cob_alloc_cache *x;
473 struct cob_alloc_cache *y;
474
475 #ifdef HAVE_SETLOCALE
476 if (cobglobptr->cob_locale_orig) {
477 (void) setlocale (LC_ALL, cobglobptr->cob_locale_orig);
478 cob_free (cobglobptr->cob_locale_orig);
479 }
480 if (cobglobptr->cob_locale) {
481 cob_free (cobglobptr->cob_locale);
482 }
483 if (cobglobptr->cob_locale_ctype) {
484 cob_free (cobglobptr->cob_locale_ctype);
485 }
486 if (cobglobptr->cob_locale_collate) {
487 cob_free (cobglobptr->cob_locale_collate);
488 }
489 if (cobglobptr->cob_locale_messages) {
490 cob_free (cobglobptr->cob_locale_messages);
491 }
492 if (cobglobptr->cob_locale_monetary) {
493 cob_free (cobglobptr->cob_locale_monetary);
494 }
495 if (cobglobptr->cob_locale_numeric) {
496 cob_free (cobglobptr->cob_locale_numeric);
497 }
498 if (cobglobptr->cob_locale_time) {
499 cob_free (cobglobptr->cob_locale_time);
500 }
501 #endif
502
503 if (commlnptr) {
504 cob_free (commlnptr);
505 }
506 if (cob_local_env) {
507 cob_free (cob_local_env);
508 }
509
510 /* Free library routine stuff */
511
512 if (cobglobptr->cob_term_buff) {
513 cob_free (cobglobptr->cob_term_buff);
514 }
515
516 /* Free cached externals */
517 for (p = basext; p;) {
518 q = p;
519 p = p->next;
520 if (q->ename) {
521 cob_free (q->ename);
522 }
523 if (q->ext_alloc) {
524 cob_free (q->ext_alloc);
525 }
526 cob_free (q);
527 }
528
529 /* Free cached mallocs */
530 for (x = cob_alloc_base; x;) {
531 y = x;
532 x = x->next;
533 cob_free (y->cob_pointer);
534 cob_free (y);
535 }
536
537 /* Free last stuff */
538 if (cob_last_sfile) {
539 cob_free ((void *)cob_last_sfile);
540 }
541 if (runtime_err_str) {
542 cob_free (runtime_err_str);
543 }
544 if (cobglobptr) {
545 if (cobglobptr->cob_main_argv0) {
546 cob_free ((void *)(cobglobptr->cob_main_argv0));
547 }
548 cob_free (cobglobptr);
549 cobglobptr = NULL;
550 }
551 if (cobsetptr) {
552 void *data;
553 char *str;
554 unsigned int i;
555 if (cobsetptr->cob_config_file) {
556 for (i = 0; i < cobsetptr->cob_config_num; i++) {
557 if (cobsetptr->cob_config_file[i]) {
558 cob_free ((void *)cobsetptr->cob_config_file[i]);
559 }
560 }
561 cob_free ((void *)cobsetptr->cob_config_file);
562 }
563 /* Free all strings pointed to by cobsetptr */
564 for (i = 0; i < NUM_CONFIG; i++) {
565 if ((gc_conf[i].data_type & ENV_STR)
566 || (gc_conf[i].data_type & ENV_FILE)
567 || (gc_conf[i].data_type & ENV_PATH)) { /* String/Path to be stored as a string */
568 data = (void *)((char *)cobsetptr + gc_conf[i].data_loc);
569 memcpy (&str, data, sizeof (char *));
570 if (str != NULL) {
571 cob_free ((void *)str);
572 str = NULL;
573 memcpy (data, &str, sizeof (char *)); /* Reset pointer to NULL */
574 }
575 }
576 }
577 if (cobsetptr->cob_preload_str_set) {
578 cob_free((void*)(cobsetptr->cob_preload_str_set));
579 }
580 cob_free (cobsetptr);
581 cobsetptr = NULL;
582 }
583 cob_initialized = 0;
584 }
585
586 static void
cob_exit_common_modules(void)587 cob_exit_common_modules (void)
588 {
589 cob_module *mod;
590 struct cob_alloc_module *ptr, *nxt;
591 int (*cancel_func)(const int);
592
593 /* Call each module to release local memory
594 - currently used for: decimals -
595 and remove it from the internal module list */
596 for (ptr = cob_module_list; ptr; ptr = nxt) {
597 mod = ptr->cob_pointer;
598 nxt = ptr->next;
599 if (mod && mod->module_cancel.funcint) {
600 mod->module_active = 0;
601 cancel_func = mod->module_cancel.funcint;
602 (void)cancel_func (-20); /* Clear just decimals */
603 }
604 cob_free (ptr);
605 }
606 cob_module_list = NULL;
607 }
608
609 static void
cob_terminate_routines(void)610 cob_terminate_routines (void)
611 {
612 if (!cob_initialized || !cobglobptr) {
613 return;
614 }
615 cob_exit_fileio_msg_only ();
616
617 if (COB_MODULE_PTR && abort_reason[0] != 0) {
618 if (cobsetptr->cob_stacktrace) {
619 if (!(dump_trace_started & (DUMP_TRACE_DONE_TRACE | DUMP_TRACE_ACTIVE_TRACE))) {
620 dump_trace_started |= DUMP_TRACE_DONE_TRACE;
621 dump_trace_started |= DUMP_TRACE_ACTIVE_TRACE;
622 cob_stack_trace_internal (stderr);
623 dump_trace_started ^= DUMP_TRACE_ACTIVE_TRACE;
624 }
625 }
626 if (!(dump_trace_started & DUMP_TRACE_DONE_DUMP)) {
627 dump_trace_started |= DUMP_TRACE_DONE_DUMP;
628 cob_dump_module (abort_reason);
629 }
630 }
631
632 if (cobsetptr->cob_dump_file == cobsetptr->cob_trace_file
633 || cobsetptr->cob_dump_file == stderr) {
634 cobsetptr->cob_dump_file = NULL;
635 }
636
637 if (cobsetptr->cob_dump_file) {
638 fclose (cobsetptr->cob_dump_file);
639 cobsetptr->cob_dump_file = NULL;
640 }
641
642 #ifdef COB_DEBUG_LOG
643 /* close debug log (delete file if empty) */
644 if (cob_debug_file
645 && cob_debug_file != stderr) {
646 /* note: cob_debug_file can only be identical to cob_trace_file
647 if same file name was used, not with external_trace_file */
648 if (cob_debug_file == cobsetptr->cob_trace_file) {
649 cobsetptr->cob_trace_file = NULL;
650 }
651 if (cob_debug_file_name != NULL
652 && ftell (cob_debug_file) == 0) {
653 fclose (cob_debug_file);
654 unlink (cob_debug_file_name);
655 } else {
656 fclose (cob_debug_file);
657 }
658 }
659 cob_debug_file = NULL;
660 if (cob_debug_file_name) {
661 cob_free (cob_debug_file_name);
662 cob_debug_file_name = NULL;
663 }
664 #endif
665
666 if (cobsetptr->cob_trace_file
667 && cobsetptr->cob_trace_file != stderr
668 && !cobsetptr->external_trace_file /* note: may include stdout */) {
669 fclose (cobsetptr->cob_trace_file);
670 }
671 cobsetptr->cob_trace_file = NULL;
672
673 /* close punch file if self-opened */
674 if (cobsetptr->cob_display_punch_file
675 && cobsetptr->cob_display_punch_filename) {
676 fclose (cobsetptr->cob_display_punch_file);
677 cobsetptr->cob_display_punch_file = NULL;
678 }
679
680 cob_exit_screen ();
681 cob_exit_fileio ();
682 cob_exit_reportio ();
683 cob_exit_mlio ();
684
685 cob_exit_intrinsic ();
686 cob_exit_strings ();
687 cob_exit_numeric ();
688
689 cob_exit_common_modules ();
690 cob_exit_call ();
691 cob_exit_common ();
692 }
693
694 /* reentrant version of strerror */
695 static char *
cob_get_strerror(void)696 cob_get_strerror (void)
697 {
698 char * msg;
699 msg = cob_cache_malloc ((size_t)COB_ERRBUF_SIZE);
700 #ifdef HAVE_STRERROR
701 strncpy (msg, strerror (errno), COB_ERRBUF_SIZE - 1);
702 #else
703 snprintf (msg, COB_ERRBUF_SIZE - 1, _("system error %d"), errno);
704 #endif
705 return msg;
706 }
707
708 /* LCOV_EXCL_START */
709 static const char *
get_signal_name(int signal_value)710 get_signal_name (int signal_value)
711 {
712 switch (signal_value) {
713 #ifdef SIGINT
714 case SIGINT:
715 return "SIGINT";
716 #endif
717 #ifdef SIGHUP
718 case SIGHUP:
719 return "SIGHUP";
720 #endif
721 #ifdef SIGQUIT
722 case SIGQUIT:
723 return "SIGQUIT";
724 #endif
725 #ifdef SIGTERM
726 case SIGTERM:
727 return "SIGTERM";
728 #endif
729 #ifdef SIGEMT
730 case SIGEMT:
731 return "SIGEMT";
732 #endif
733 #ifdef SIGPIPE
734 case SIGPIPE:
735 return "SIGPIPE";
736 #endif
737 #ifdef SIGSEGV
738 case SIGSEGV:
739 return "SIGSEGV";
740 #endif
741 #ifdef SIGBUS
742 case SIGBUS:
743 return "SIGBUS";
744 #endif
745 #ifdef SIGFPE
746 case SIGFPE:
747 return "SIGFPE";
748 #endif
749 default:
750 return NULL;
751 }
752 }
753 /* LCOV_EXCL_STOP */
754
755 #ifdef HAVE_SIGNAL_H
756 DECLNORET static void COB_A_NORETURN
cob_sig_handler_ex(int sig)757 cob_sig_handler_ex (int sig)
758 {
759 /* call external signal handler if registered */
760 if (cob_ext_sighdl != NULL) {
761 (*cob_ext_sighdl) (sig);
762 cob_ext_sighdl = NULL;
763 }
764 #ifdef SIGSEGV
765 if (sig == SIGSEGV) {
766 exit (SIGSEGV);
767 }
768 #endif
769 #ifdef HAVE_RAISE
770 raise (sig);
771 #else
772 kill (cob_sys_getpid (), sig);
773 #endif
774 exit (sig);
775 }
776
777
778 DECLNORET static void COB_A_NORETURN
cob_sig_handler(int signal_value)779 cob_sig_handler (int signal_value)
780 {
781 const char *signal_name;
782 char signal_text[COB_MINI_BUFF];
783
784 #if defined (HAVE_SIGACTION) && !defined (SA_RESETHAND)
785 struct sigaction sa;
786 #endif
787
788 #if 0 /* Do we flush whatever we may have in our streams ? */
789 fflush (stdout);
790 fflush (stderr);
791 #endif
792
793 #ifdef HAVE_SIG_ATOMIC_T
794 if (sig_is_handled) {
795 cob_sig_handler_ex (signal_value);
796 }
797 sig_is_handled = 1;
798 #endif
799
800 signal_name = get_signal_name (signal_value);
801 /* LCOV_EXCL_START */
802 if (!signal_name) {
803 /* not translated as it is a very unlikely error case */
804 fprintf (stderr, "cob_sig_handler caught not handled signal: %d", signal_value);
805 putc ('\n', stderr);
806 signal_name = _("unknown");
807 }
808 /* LCOV_EXCL_STOP */
809
810 /* Skip dumping for SIGTERM and SIGINT */
811 #ifdef SIGTERM
812 if (signal_value == SIGTERM) {
813 dump_trace_started |= DUMP_TRACE_DONE_DUMP;
814 }
815 #endif
816 #ifdef SIGINT
817 if (signal_value == SIGINT) {
818 dump_trace_started |= DUMP_TRACE_DONE_DUMP;
819 }
820 #endif
821
822 #ifdef HAVE_SIGACTION
823 #ifndef SA_RESETHAND
824 memset (&sa, 0, sizeof (sa));
825 sa.sa_handler = SIG_DFL;
826 (void)sigemptyset (&sa.sa_mask);
827 (void)sigaction (signal_value, &sa, NULL);
828 #endif
829 #else
830 (void)signal (signal_value, SIG_DFL);
831 #endif
832 cob_exit_screen ();
833 putc ('\n', stderr);
834 if (cob_source_file) {
835 fprintf (stderr, "%s:", cob_source_file);
836 if (cob_source_line) {
837 fprintf (stderr, "%u:", cob_source_line);
838 }
839 fputc (' ', stderr);
840 }
841
842 /* LCOV_EXCL_START */
843 switch (signal_value) {
844 #ifdef SIGSEGV
845 case SIGSEGV:
846 fprintf (stderr, _("attempt to reference unallocated memory"));
847 break;
848 #endif
849 #ifdef SIGBUS
850 case SIGBUS:
851 fprintf (stderr, _("bus error"));
852 break;
853 #endif
854 #ifdef SIGFPE
855 case SIGFPE:
856 fprintf (stderr, _("fatal arithmetic error"));
857 break;
858 #endif
859 default:
860 fprintf (stderr, _("caught signal"));
861 break;
862 }
863 /* LCOV_EXCL_STOP */
864 snprintf (signal_text, COB_MINI_MAX, _("signal %s"), signal_name);
865 fprintf (stderr, " (%s)\n", signal_text);
866
867 fputc ('\n', stderr);
868 fflush (stderr);
869
870 if (cob_initialized) {
871 if (abort_reason[0] == 0) {
872 memcpy (abort_reason, signal_text, COB_MINI_BUFF);
873 #if 0 /* Is there a use in this message ?*/
874 fputs (_("abnormal termination - file contents may be incorrect"), stderr);
875 fputc ('\n', stderr);
876 #endif
877 }
878 cob_terminate_routines ();
879 }
880
881 cob_sig_handler_ex (signal_value);
882 }
883 #endif /* HAVE_SIGNAL_H */
884
885 /* Raise signal (run both internal and external handlers)
886 may return, depending on the signal
887 */
888 void
cob_raise(int sig)889 cob_raise (int sig)
890 {
891 #ifdef HAVE_SIGNAL_H
892 /* let the registered signal handlers do their work */
893 #ifdef HAVE_RAISE
894 raise (sig);
895 #else
896 kill (cob_sys_getpid (), sig);
897 #endif
898 /* else: at least call external signal handler if registered */
899 #else
900 if (cob_ext_sighdl != NULL) {
901 (*cob_ext_sighdl) (sig);
902 cob_ext_sighdl = NULL;
903 }
904 #endif
905 }
906
907 static void
cob_set_signal(void)908 cob_set_signal (void)
909 {
910 #ifdef HAVE_SIGNAL_H
911
912 #ifdef HAVE_SIGACTION
913 struct sigaction sa;
914 struct sigaction osa;
915
916 memset (&sa, 0, sizeof (sa));
917 sa.sa_handler = cob_sig_handler;
918 #ifdef SA_RESETHAND
919 sa.sa_flags = SA_RESETHAND;
920 #else
921 sa.sa_flags = 0;
922 #endif
923 #ifdef SA_NOCLDSTOP
924 sa.sa_flags |= SA_NOCLDSTOP;
925 #endif
926
927 #ifdef SIGINT
928 (void)sigaction (SIGINT, NULL, &osa);
929 if (osa.sa_handler != SIG_IGN) {
930 (void)sigemptyset (&sa.sa_mask);
931 (void)sigaction (SIGINT, &sa, NULL);
932 }
933 #endif
934 #ifdef SIGHUP
935 (void)sigaction (SIGHUP, NULL, &osa);
936 if (osa.sa_handler != SIG_IGN) {
937 (void)sigemptyset (&sa.sa_mask);
938 (void)sigaction (SIGHUP, &sa, NULL);
939 }
940 #endif
941 #ifdef SIGQUIT
942 (void)sigaction (SIGQUIT, NULL, &osa);
943 if (osa.sa_handler != SIG_IGN) {
944 (void)sigemptyset (&sa.sa_mask);
945 (void)sigaction (SIGQUIT, &sa, NULL);
946 }
947 #endif
948 #ifdef SIGTERM
949 (void)sigaction (SIGTERM, NULL, &osa);
950 if (osa.sa_handler != SIG_IGN) {
951 (void)sigemptyset (&sa.sa_mask);
952 (void)sigaction (SIGTERM, &sa, NULL);
953 }
954 #endif
955 #ifdef SIGEMT
956 (void)sigaction (SIGEMT, NULL, &osa);
957 if (osa.sa_handler != SIG_IGN) {
958 (void)sigemptyset (&sa.sa_mask);
959 (void)sigaction (SIGEMT, &sa, NULL);
960 }
961 #endif
962 #ifdef SIGPIPE
963 (void)sigaction (SIGPIPE, NULL, &osa);
964 if (osa.sa_handler != SIG_IGN) {
965 (void)sigemptyset (&sa.sa_mask);
966 (void)sigaction (SIGPIPE, &sa, NULL);
967 }
968 #endif
969 #ifdef SIGSEGV
970 /* Take direct control of segmentation violation */
971 (void)sigemptyset (&sa.sa_mask);
972 (void)sigaction (SIGSEGV, &sa, NULL);
973 #endif
974 #ifdef SIGBUS
975 /* Take direct control of bus error */
976 (void)sigemptyset (&sa.sa_mask);
977 (void)sigaction (SIGBUS, &sa, NULL);
978 #endif
979 #ifdef SIGFPE
980 /* fatal arithmetic errors including non-floating-point division by zero */
981 (void)sigaction (SIGFPE, NULL, &osa);
982 if (osa.sa_handler != SIG_IGN) {
983 (void)sigemptyset (&sa.sa_mask);
984 (void)sigaction (SIGFPE, &sa, NULL);
985 }
986 #endif
987
988 #else
989
990 #ifdef SIGINT
991 if (signal (SIGINT, SIG_IGN) != SIG_IGN) {
992 (void)signal (SIGINT, cob_sig_handler);
993 }
994 #endif
995 #ifdef SIGHUP
996 if (signal (SIGHUP, SIG_IGN) != SIG_IGN) {
997 (void)signal (SIGHUP, cob_sig_handler);
998 }
999 #endif
1000 #ifdef SIGQUIT
1001 if (signal (SIGQUIT, SIG_IGN) != SIG_IGN) {
1002 (void)signal (SIGQUIT, cob_sig_handler);
1003 }
1004 #endif
1005 #ifdef SIGTERM
1006 if (signal (SIGTERM, SIG_IGN) != SIG_IGN) {
1007 (void)signal (SIGTERM, cob_sig_handler);
1008 }
1009 #endif
1010 #ifdef SIGEMT
1011 if (signal (SIGEMT, SIG_IGN) != SIG_IGN) {
1012 (void)signal (SIGEMT, cob_sig_handler);
1013 }
1014 #endif
1015 #ifdef SIGPIPE
1016 if (signal (SIGPIPE, SIG_IGN) != SIG_IGN) {
1017 (void)signal (SIGPIPE, cob_sig_handler);
1018 }
1019 #endif
1020 #ifdef SIGSEGV
1021 /* Take direct control of segmentation violation */
1022 (void)signal (SIGSEGV, cob_sig_handler);
1023 #endif
1024 #ifdef SIGBUS
1025 /* Take direct control of bus error */
1026 (void)signal (SIGBUS, cob_sig_handler);
1027 #endif
1028 #ifdef SIGFPE
1029 if (signal (SIGFPE, SIG_IGN) != SIG_IGN) {
1030 (void)signal (SIGFPE, cob_sig_handler);
1031 }
1032 #endif
1033
1034 #endif
1035 #endif
1036 }
1037
1038 /* ASCII Sign
1039 * positive: 0123456789
1040 * negative: pqrstuvwxy
1041 */
1042
1043 static int
cob_get_sign_ascii(unsigned char * p)1044 cob_get_sign_ascii (unsigned char *p)
1045 {
1046 #ifdef COB_EBCDIC_MACHINE
1047 switch (*p) {
1048 case 'p':
1049 *p = (unsigned char)'0';
1050 return -1;
1051 case 'q':
1052 *p = (unsigned char)'1';
1053 return -1;
1054 case 'r':
1055 *p = (unsigned char)'2';
1056 return -1;
1057 case 's':
1058 *p = (unsigned char)'3';
1059 return -1;
1060 case 't':
1061 *p = (unsigned char)'4';
1062 return -1;
1063 case 'u':
1064 *p = (unsigned char)'5';
1065 return -1;
1066 case 'v':
1067 *p = (unsigned char)'6';
1068 return -1;
1069 case 'w':
1070 *p = (unsigned char)'7';
1071 return -1;
1072 case 'x':
1073 *p = (unsigned char)'8';
1074 return -1;
1075 case 'y':
1076 *p = (unsigned char)'9';
1077 return -1;
1078 }
1079 *p = (unsigned char)'0';
1080 return 1;
1081 #else
1082 if (*p >= (unsigned char)'p' && *p <= (unsigned char)'y') {
1083 *p &= ~64U;
1084 return -1;
1085 }
1086 *p = (unsigned char)'0';
1087 return 1;
1088 #endif
1089 }
1090
1091 static void
cob_put_sign_ascii(unsigned char * p)1092 cob_put_sign_ascii (unsigned char *p)
1093 {
1094 #ifdef COB_EBCDIC_MACHINE
1095 switch (*p) {
1096 case '0':
1097 *p = (unsigned char)'p';
1098 return;
1099 case '1':
1100 *p = (unsigned char)'q';
1101 return;
1102 case '2':
1103 *p = (unsigned char)'r';
1104 return;
1105 case '3':
1106 *p = (unsigned char)'s';
1107 return;
1108 case '4':
1109 *p = (unsigned char)'t';
1110 return;
1111 case '5':
1112 *p = (unsigned char)'u';
1113 return;
1114 case '6':
1115 *p = (unsigned char)'v';
1116 return;
1117 case '7':
1118 *p = (unsigned char)'w';
1119 return;
1120 case '8':
1121 *p = (unsigned char)'x';
1122 return;
1123 case '9':
1124 *p = (unsigned char)'y';
1125 return;
1126 default:
1127 *p = (unsigned char)'0';
1128 }
1129 #else
1130 *p |= 64U;
1131 #endif
1132 }
1133
1134 /* EBCDIC Sign
1135 * positive: {ABCDEFGHI
1136 * negative: }JKLMNOPQR
1137 */
1138
1139 static int
cob_get_sign_ebcdic(unsigned char * p)1140 cob_get_sign_ebcdic (unsigned char *p)
1141 {
1142 switch (*p) {
1143 case '{':
1144 *p = (unsigned char)'0';
1145 return 1;
1146 case 'A':
1147 *p = (unsigned char)'1';
1148 return 1;
1149 case 'B':
1150 *p = (unsigned char)'2';
1151 return 1;
1152 case 'C':
1153 *p = (unsigned char)'3';
1154 return 1;
1155 case 'D':
1156 *p = (unsigned char)'4';
1157 return 1;
1158 case 'E':
1159 *p = (unsigned char)'5';
1160 return 1;
1161 case 'F':
1162 *p = (unsigned char)'6';
1163 return 1;
1164 case 'G':
1165 *p = (unsigned char)'7';
1166 return 1;
1167 case 'H':
1168 *p = (unsigned char)'8';
1169 return 1;
1170 case 'I':
1171 *p = (unsigned char)'9';
1172 return 1;
1173 case '}':
1174 *p = (unsigned char)'0';
1175 return -1;
1176 case 'J':
1177 *p = (unsigned char)'1';
1178 return -1;
1179 case 'K':
1180 *p = (unsigned char)'2';
1181 return -1;
1182 case 'L':
1183 *p = (unsigned char)'3';
1184 return -1;
1185 case 'M':
1186 *p = (unsigned char)'4';
1187 return -1;
1188 case 'N':
1189 *p = (unsigned char)'5';
1190 return -1;
1191 case 'O':
1192 *p = (unsigned char)'6';
1193 return -1;
1194 case 'P':
1195 *p = (unsigned char)'7';
1196 return -1;
1197 case 'Q':
1198 *p = (unsigned char)'8';
1199 return -1;
1200 case 'R':
1201 *p = (unsigned char)'9';
1202 return -1;
1203 default:
1204 /* What to do here */
1205 *p = (unsigned char)('0' + (*p & 0x0F));
1206 if (*p > (unsigned char)'9') {
1207 *p = (unsigned char)'0';
1208 }
1209 return 1;
1210 }
1211 }
1212
1213 static void
cob_put_sign_ebcdic(unsigned char * p,const int sign)1214 cob_put_sign_ebcdic (unsigned char *p, const int sign)
1215 {
1216 if (sign < 0) {
1217 switch (*p) {
1218 case '0':
1219 *p = (unsigned char)'}';
1220 return;
1221 case '1':
1222 *p = (unsigned char)'J';
1223 return;
1224 case '2':
1225 *p = (unsigned char)'K';
1226 return;
1227 case '3':
1228 *p = (unsigned char)'L';
1229 return;
1230 case '4':
1231 *p = (unsigned char)'M';
1232 return;
1233 case '5':
1234 *p = (unsigned char)'N';
1235 return;
1236 case '6':
1237 *p = (unsigned char)'O';
1238 return;
1239 case '7':
1240 *p = (unsigned char)'P';
1241 return;
1242 case '8':
1243 *p = (unsigned char)'Q';
1244 return;
1245 case '9':
1246 *p = (unsigned char)'R';
1247 return;
1248 default:
1249 /* What to do here */
1250 *p = (unsigned char)'{';
1251 return;
1252 }
1253 }
1254 switch (*p) {
1255 case '0':
1256 *p = (unsigned char)'{';
1257 return;
1258 case '1':
1259 *p = (unsigned char)'A';
1260 return;
1261 case '2':
1262 *p = (unsigned char)'B';
1263 return;
1264 case '3':
1265 *p = (unsigned char)'C';
1266 return;
1267 case '4':
1268 *p = (unsigned char)'D';
1269 return;
1270 case '5':
1271 *p = (unsigned char)'E';
1272 return;
1273 case '6':
1274 *p = (unsigned char)'F';
1275 return;
1276 case '7':
1277 *p = (unsigned char)'G';
1278 return;
1279 case '8':
1280 *p = (unsigned char)'H';
1281 return;
1282 case '9':
1283 *p = (unsigned char)'I';
1284 return;
1285 default:
1286 /* What to do here */
1287 *p = (unsigned char)'{';
1288 return;
1289 }
1290 }
1291
1292 static int
common_cmpc(const unsigned char * s1,const unsigned int c,const size_t size,const unsigned char * col)1293 common_cmpc (const unsigned char *s1, const unsigned int c,
1294 const size_t size, const unsigned char *col)
1295 {
1296 size_t i;
1297 int ret;
1298
1299 if (unlikely (col)) {
1300 for (i = 0; i < size; ++i) {
1301 if ((ret = col[s1[i]] - col[c]) != 0) {
1302 return ret;
1303 }
1304 }
1305 } else {
1306 for (i = 0; i < size; ++i) {
1307 if ((ret = s1[i] - c) != 0) {
1308 return ret;
1309 }
1310 }
1311 }
1312 return 0;
1313 }
1314
1315 static int
common_cmps(const unsigned char * s1,const unsigned char * s2,const size_t size,const unsigned char * col)1316 common_cmps (const unsigned char *s1, const unsigned char *s2,
1317 const size_t size, const unsigned char *col)
1318 {
1319 size_t i;
1320 int ret;
1321
1322 if (unlikely (col)) {
1323 for (i = 0; i < size; ++i) {
1324 if ((ret = col[s1[i]] - col[s2[i]]) != 0) {
1325 return ret;
1326 }
1327 }
1328 } else {
1329 for (i = 0; i < size; ++i) {
1330 if ((ret = s1[i] - s2[i]) != 0) {
1331 return ret;
1332 }
1333 }
1334 }
1335 return 0;
1336 }
1337
1338 static int
cob_cmp_all(cob_field * f1,cob_field * f2)1339 cob_cmp_all (cob_field *f1, cob_field *f2)
1340 {
1341 unsigned char *data;
1342 const unsigned char *s;
1343 size_t size;
1344 int ret;
1345 int sign;
1346
1347 size = f1->size;
1348 data = f1->data;
1349 sign = COB_GET_SIGN (f1);
1350 s = COB_MODULE_PTR->collating_sequence;
1351 if (f2->size == 1) {
1352 ret = common_cmpc (data, f2->data[0], size, s);
1353 goto end;
1354 }
1355 ret = 0;
1356 while (size >= f2->size) {
1357 if ((ret = common_cmps (data, f2->data, f2->size, s)) != 0) {
1358 goto end;
1359 }
1360 size -= f2->size;
1361 data += f2->size;
1362 }
1363 if (size > 0) {
1364 ret = common_cmps (data, f2->data, size, s);
1365 }
1366
1367 end:
1368 if (COB_FIELD_TYPE (f1) != COB_TYPE_NUMERIC_PACKED) {
1369 COB_PUT_SIGN (f1, sign);
1370 }
1371 return ret;
1372 }
1373
1374 static int
cob_cmp_alnum(cob_field * f1,cob_field * f2)1375 cob_cmp_alnum (cob_field *f1, cob_field *f2)
1376 {
1377 const unsigned char *s;
1378 size_t min;
1379 int ret;
1380 int sign1;
1381 int sign2;
1382
1383 /* FIXME later: must cater for national fields, too */
1384
1385 sign1 = COB_GET_SIGN (f1);
1386 sign2 = COB_GET_SIGN (f2);
1387 min = (f1->size < f2->size) ? f1->size : f2->size;
1388 s = COB_MODULE_PTR->collating_sequence;
1389
1390 /* Compare common substring */
1391 if ((ret = common_cmps (f1->data, f2->data, min, s)) != 0) {
1392 goto end;
1393 }
1394
1395 /* Compare the rest (if any) with spaces */
1396 if (f1->size > f2->size) {
1397 ret = common_cmpc (f1->data + min, ' ', f1->size - min, s);
1398 } else if (f1->size < f2->size) {
1399 ret = -common_cmpc (f2->data + min, ' ', f2->size - min, s);
1400 }
1401
1402 end:
1403 if (COB_FIELD_TYPE (f1) != COB_TYPE_NUMERIC_PACKED) {
1404 COB_PUT_SIGN (f1, sign1);
1405 }
1406 if (COB_FIELD_TYPE (f2) != COB_TYPE_NUMERIC_PACKED) {
1407 COB_PUT_SIGN (f2, sign2);
1408 }
1409 return ret;
1410 }
1411
1412 static int
sort_compare(const void * data1,const void * data2)1413 sort_compare (const void *data1, const void *data2)
1414 {
1415 size_t i;
1416 int res;
1417 cob_field f1;
1418 cob_field f2;
1419
1420 for (i = 0; i < sort_nkeys; ++i) {
1421 f1 = f2 = *sort_keys[i].field;
1422 f1.data = (unsigned char *)data1 + sort_keys[i].offset;
1423 f2.data = (unsigned char *)data2 + sort_keys[i].offset;
1424 if (COB_FIELD_IS_NUMERIC (&f1)) {
1425 res = cob_numeric_cmp (&f1, &f2);
1426 } else {
1427 res = common_cmps (f1.data, f2.data, f1.size, sort_collate);
1428 }
1429 if (res != 0) {
1430 return (sort_keys[i].flag == COB_ASCENDING) ? res : -res;
1431 }
1432 }
1433 return 0;
1434 }
1435
1436 static void
cob_memcpy(cob_field * dst,const void * src,const size_t size)1437 cob_memcpy (cob_field *dst, const void *src, const size_t size)
1438 {
1439 cob_field temp;
1440
1441 if (!dst->size) {
1442 return;
1443 }
1444 temp.size = size;
1445 temp.data = (cob_u8_ptr)src;
1446 temp.attr = &const_alpha_attr;
1447 cob_move (&temp, dst);
1448 }
1449
1450 /* open file using mode according to cob_unix_lf and
1451 filename (append when starting with +) */
1452 static FILE *
cob_open_logfile(const char * filename)1453 cob_open_logfile (const char *filename)
1454 {
1455 const char *mode;
1456
1457 if (!cobsetptr->cob_unix_lf) {
1458 if (*filename == '+') {
1459 filename++;
1460 mode = "a";
1461 } else {
1462 mode = "w";
1463 }
1464 } else {
1465 if (*filename == '+') {
1466 filename++;
1467 mode = "ab";
1468 } else {
1469 mode = "wb";
1470 }
1471 }
1472 return fopen (filename, mode);
1473 }
1474
1475 /* ensure that cob_trace_file is available for writing */
1476 static void
cob_check_trace_file(void)1477 cob_check_trace_file (void)
1478 {
1479
1480 if (cobsetptr->cob_trace_file) {
1481 return;
1482 }
1483 if (cobsetptr->cob_trace_filename) {
1484 cobsetptr->cob_trace_file = cob_open_logfile (cobsetptr->cob_trace_filename);
1485 if (!cobsetptr->cob_trace_file) {
1486 /* could not open the file
1487 unset the filename for not referencing it later */
1488 cobsetptr->cob_trace_filename = NULL;
1489 cobsetptr->cob_trace_file = stderr;
1490 }
1491 } else {
1492 cobsetptr->cob_trace_file = stderr;
1493 }
1494 }
1495
1496 /* close current trace file (if open) and open/attach a new one */
1497 static void
cob_new_trace_file(void)1498 cob_new_trace_file (void)
1499 {
1500 FILE *old_trace_file = cobsetptr->cob_trace_file;
1501
1502 if (!cobsetptr->cob_trace_file
1503 || cobsetptr->external_trace_file
1504 || cobsetptr->cob_trace_file == stderr) {
1505 cobsetptr->cob_trace_file = NULL;
1506 cob_check_trace_file ();
1507 return;
1508 }
1509
1510 fclose (cobsetptr->cob_trace_file);
1511 cobsetptr->cob_trace_file = NULL;
1512
1513 cob_check_trace_file ();
1514 if (cobsetptr->cob_display_print_file
1515 && cobsetptr->cob_display_print_file == old_trace_file) {
1516 cobsetptr->cob_display_print_file = cobsetptr->cob_trace_file;
1517 }
1518 if (cobsetptr->cob_dump_file
1519 && cobsetptr->cob_dump_file == old_trace_file) {
1520 cobsetptr->cob_dump_file = cobsetptr->cob_trace_file;
1521 }
1522 #ifdef COB_DEBUG_LOG
1523 if (cob_debug_file
1524 && cob_debug_file == old_trace_file) {
1525 cob_debug_file = cobsetptr->cob_trace_file;
1526 }
1527 #endif
1528 }
1529
1530 int
cob_check_env_true(char * s)1531 cob_check_env_true (char * s)
1532 {
1533 if (s) {
1534 if (strlen (s) == 1 && (*s == 'Y' || *s == 'y' || *s == '1')) return 1;
1535 if (strcasecmp (s, "YES") == 0 || strcasecmp (s, "ON") == 0 ||
1536 strcasecmp (s, "TRUE") == 0) {
1537 return 1;
1538 }
1539 }
1540 return 0;
1541 }
1542
1543 int
cob_check_env_false(char * s)1544 cob_check_env_false (char * s)
1545 {
1546 return s && ((strlen (s) == 1 && (*s == 'N' || *s == 'n' || *s == '0'))
1547 || (strcasecmp (s, "NO") == 0 || strcasecmp (s, "NONE") == 0
1548 || strcasecmp (s, "OFF") == 0
1549 || strcasecmp (s, "FALSE") == 0));
1550 }
1551
1552 static void
cob_rescan_env_vals(void)1553 cob_rescan_env_vals (void)
1554 {
1555 int i;
1556 int j;
1557 int old_type;
1558 char *env;
1559 char *save_source_file = (char *) cob_source_file;
1560
1561 cob_source_file = NULL;
1562 cob_source_line = 0;
1563
1564 /* Check for possible environment variables */
1565 for (i = 0; i < NUM_CONFIG; i++) {
1566 if (gc_conf[i].env_name
1567 && (env = getenv (gc_conf[i].env_name)) != NULL) {
1568 old_type = gc_conf[i].data_type;
1569 gc_conf[i].data_type |= STS_ENVSET;
1570
1571 if (*env != '\0' && set_config_val (env, i)) {
1572 gc_conf[i].data_type = old_type;
1573
1574 /* Remove invalid setting */
1575 (void)cob_unsetenv (gc_conf[i].env_name);
1576 } else if (gc_conf[i].env_group == GRP_HIDE) {
1577 /* Any alias present? */
1578 for (j = 0; j < NUM_CONFIG; j++) {
1579 if (j != i
1580 && gc_conf[i].data_loc == gc_conf[j].data_loc) {
1581 gc_conf[j].data_type |= STS_ENVSET;
1582 gc_conf[j].set_by = i;
1583 }
1584 }
1585 }
1586 }
1587 }
1588 cob_source_file = save_source_file;
1589
1590 /* Extended ACCEPT status returns */
1591 if (cobsetptr->cob_extended_status == 0) {
1592 cobsetptr->cob_use_esc = 0;
1593 }
1594 }
1595
1596 static int
one_indexed_day_of_week_from_monday(int zero_indexed_from_sunday)1597 one_indexed_day_of_week_from_monday (int zero_indexed_from_sunday)
1598 {
1599 return ((zero_indexed_from_sunday + 6) % 7) + 1;
1600 }
1601
1602 #if defined (_MSC_VER) && COB_USE_VC2008_OR_GREATER
1603 static void
set_cob_time_ns_from_filetime(const FILETIME filetime,struct cob_time * cb_time)1604 set_cob_time_ns_from_filetime (const FILETIME filetime, struct cob_time *cb_time)
1605 {
1606 ULONGLONG filetime_int;
1607
1608 filetime_int = (((ULONGLONG) filetime.dwHighDateTime) << 32)
1609 + filetime.dwLowDateTime;
1610 /* FILETIMEs are accurate to 100 nanosecond intervals */
1611 cb_time->nanosecond = (filetime_int % (ULONGLONG) 10000000) * 100;
1612 }
1613 #endif
1614
1615 /* Global functions */
1616
1617 /* get last exception (or 0 if not active) */
1618 int
cob_get_last_exception_code(void)1619 cob_get_last_exception_code (void)
1620 {
1621 return last_exception_code;
1622 }
1623
1624 /* get exception name for last raised exception */
1625 const char *
cob_get_last_exception_name(void)1626 cob_get_last_exception_name (void)
1627 {
1628 size_t n;
1629
1630 for (n = 0; n < EXCEPTION_TAB_SIZE; ++n) {
1631 if (last_exception_code == cob_exception_tab_code[n]) {
1632 return cob_exception_tab_name[n];
1633 }
1634 }
1635 return NULL;
1636 }
1637
1638 /* check if last exception is set and includes the given exception */
1639 int
cob_last_exception_is(const int exception_to_check)1640 cob_last_exception_is (const int exception_to_check)
1641 {
1642 if ((last_exception_code & cob_exception_tab_code[exception_to_check])
1643 == cob_exception_tab_code[exception_to_check]) {
1644 return 1;
1645 } else {
1646 return 0;
1647 }
1648 }
1649
1650 /* set last exception,
1651 used for EXCEPTION- functions and for cob_accept_exception_status,
1652 only reset on SET LAST EXCEPTION TO OFF */
1653 void
cob_set_exception(const int id)1654 cob_set_exception (const int id)
1655 {
1656 cobglobptr->cob_exception_code = cob_exception_tab_code[id];
1657 last_exception_code = cobglobptr->cob_exception_code;
1658 if (id) {
1659 cobglobptr->cob_got_exception = 1;
1660 cobglobptr->last_exception_statement = cob_source_statement;
1661 cobglobptr->last_exception_line = cob_source_line;
1662 cobglobptr->last_exception_id = cob_current_program_id;
1663 cobglobptr->last_exception_section = cob_current_section;
1664 cobglobptr->last_exception_paragraph = cob_current_paragraph;
1665 } else {
1666 cobglobptr->cob_got_exception = 0;
1667 cobglobptr->last_exception_statement = NULL;
1668 cobglobptr->last_exception_line = 0;
1669 cobglobptr->last_exception_id = NULL;
1670 cobglobptr->last_exception_section = NULL;
1671 cobglobptr->last_exception_paragraph = NULL;
1672 }
1673 }
1674
1675 /* return the last exception value */
1676 void
cob_accept_exception_status(cob_field * f)1677 cob_accept_exception_status (cob_field *f)
1678 {
1679 /* Note: MF set this to a 9(3) item, we may
1680 add a translation here */
1681 cob_set_int (f, last_exception_code);
1682 }
1683
1684 void
cob_accept_user_name(cob_field * f)1685 cob_accept_user_name (cob_field *f)
1686 {
1687 if (cobsetptr->cob_user_name) {
1688 cob_memcpy (f, cobsetptr->cob_user_name,
1689 strlen (cobsetptr->cob_user_name));
1690 } else {
1691 cob_memcpy (f, " ", (size_t)1);
1692 }
1693 }
1694
1695 void *
cob_malloc(const size_t size)1696 cob_malloc (const size_t size)
1697 {
1698 void *mptr;
1699
1700 mptr = calloc ((size_t)1, size);
1701 /* LCOV_EXCL_START */
1702 if (unlikely (!mptr)) {
1703 cob_fatal_error (COB_FERROR_MEMORY);
1704 }
1705 /* LCOV_EXCL_STOP */
1706 return mptr;
1707 }
1708
1709 void *
cob_realloc(void * optr,const size_t osize,const size_t nsize)1710 cob_realloc (void * optr, const size_t osize, const size_t nsize)
1711 {
1712 void *mptr;
1713
1714 /* LCOV_EXCL_START */
1715 if (unlikely (!optr)) {
1716 cob_fatal_error (COB_FERROR_FREE);
1717 }
1718 /* LCOV_EXCL_STOP */
1719
1720 if (unlikely (osize == nsize)) { /* No size change */
1721 return optr;
1722 }
1723 if (unlikely (osize > nsize)) { /* Reducing size */
1724 return realloc (optr, nsize);
1725 }
1726
1727 mptr = calloc ((size_t)1, nsize); /* New memory, past old is cleared */
1728 /* LCOV_EXCL_START */
1729 if (unlikely (!mptr)) {
1730 cob_fatal_error (COB_FERROR_MEMORY);
1731 }
1732 /* LCOV_EXCL_STOP */
1733 memcpy (mptr, optr, osize);
1734 cob_free (optr);
1735 return mptr;
1736 }
1737
1738 void
cob_free(void * mptr)1739 cob_free (void * mptr)
1740 {
1741 #ifdef _DEBUG
1742 /* LCOV_EXCL_START */
1743 if (unlikely (!mptr)) {
1744 cob_fatal_error (COB_FERROR_FREE);
1745 }
1746 /* LCOV_EXCL_STOP */
1747 #endif
1748 free (mptr);
1749
1750 }
1751
1752 void *
cob_fast_malloc(const size_t size)1753 cob_fast_malloc (const size_t size)
1754 {
1755 void *mptr;
1756
1757 mptr = malloc (size);
1758 /* LCOV_EXCL_START */
1759 if (unlikely (!mptr)) {
1760 cob_fatal_error (COB_FERROR_MEMORY);
1761 }
1762 /* LCOV_EXCL_STOP */
1763 return mptr;
1764 }
1765
1766 char *
cob_strdup(const char * p)1767 cob_strdup (const char *p)
1768 {
1769 char *mptr;
1770 size_t len;
1771
1772 len = strlen (p) + 1;
1773 mptr = (char *)cob_fast_malloc (len);
1774 memcpy (mptr, p, len);
1775 return mptr;
1776 }
1777
1778 /* Caching versions of malloc/free */
1779 void *
cob_cache_malloc(const size_t size)1780 cob_cache_malloc (const size_t size)
1781 {
1782 struct cob_alloc_cache *cache_ptr;
1783 void *mptr;
1784
1785 cache_ptr = cob_malloc (sizeof (struct cob_alloc_cache));
1786 mptr = cob_malloc (size);
1787 cache_ptr->cob_pointer = mptr;
1788 cache_ptr->size = size;
1789 cache_ptr->next = cob_alloc_base;
1790 cob_alloc_base = cache_ptr;
1791 return mptr;
1792 }
1793
1794 void *
cob_cache_realloc(void * ptr,const size_t size)1795 cob_cache_realloc (void *ptr, const size_t size)
1796 {
1797 struct cob_alloc_cache *cache_ptr;
1798 void *mptr;
1799
1800 if (!ptr) {
1801 return cob_cache_malloc (size);
1802 }
1803 cache_ptr = cob_alloc_base;
1804 for (; cache_ptr; cache_ptr = cache_ptr->next) {
1805 if (ptr == cache_ptr->cob_pointer) {
1806 if (size <= cache_ptr->size) {
1807 return ptr;
1808 }
1809 mptr = cob_malloc (size);
1810 memcpy (mptr, cache_ptr->cob_pointer, cache_ptr->size);
1811 cob_free (cache_ptr->cob_pointer);
1812 cache_ptr->cob_pointer = mptr;
1813 cache_ptr->size = size;
1814 return mptr;
1815 }
1816 }
1817 return ptr;
1818 }
1819
1820 void
cob_cache_free(void * ptr)1821 cob_cache_free (void *ptr)
1822 {
1823 struct cob_alloc_cache *cache_ptr;
1824 struct cob_alloc_cache *prev_ptr;
1825
1826 if (!ptr) {
1827 return;
1828 }
1829 cache_ptr = cob_alloc_base;
1830 prev_ptr = cob_alloc_base;
1831 for (; cache_ptr; cache_ptr = cache_ptr->next) {
1832 if (ptr == cache_ptr->cob_pointer) {
1833 cob_free (cache_ptr->cob_pointer);
1834 if (cache_ptr == cob_alloc_base) {
1835 cob_alloc_base = cache_ptr->next;
1836 } else {
1837 prev_ptr->next = cache_ptr->next;
1838 }
1839 cob_free (cache_ptr);
1840 return;
1841 }
1842 prev_ptr = cache_ptr;
1843 }
1844 }
1845
1846 /* cob_set_location is kept for backward compatibility (pre 3.0) */
1847 void
cob_set_location(const char * sfile,const unsigned int sline,const char * csect,const char * cpara,const char * cstatement)1848 cob_set_location (const char *sfile, const unsigned int sline,
1849 const char *csect, const char *cpara,
1850 const char *cstatement)
1851 {
1852 const char *s;
1853
1854 cob_current_program_id = COB_MODULE_PTR->module_name;
1855 cob_source_file = sfile;
1856 cob_source_line = sline;
1857 cob_current_section = csect;
1858 cob_current_paragraph = cpara;
1859 if (cstatement) {
1860 cob_source_statement = cstatement;
1861 }
1862 if (cobsetptr->cob_line_trace) {
1863 if (!cobsetptr->cob_trace_file) {
1864 cob_check_trace_file ();
1865 #if _MSC_VER /* fix dumb warning */
1866 if (!cobsetptr->cob_trace_file) {
1867 return;
1868 }
1869 #endif
1870 }
1871 if (!cob_last_sfile || strcmp (cob_last_sfile, sfile)) {
1872 if (cob_last_sfile) {
1873 cob_free ((void *)cob_last_sfile);
1874 }
1875 cob_last_sfile = cob_strdup (sfile);
1876 fprintf (cobsetptr->cob_trace_file, "Source : '%s'\n", sfile);
1877 }
1878 if (COB_MODULE_PTR->module_name) {
1879 s = COB_MODULE_PTR->module_name;
1880 } else {
1881 s = _("unknown");
1882 }
1883 fprintf (cobsetptr->cob_trace_file,
1884 "Program-Id: %-16s Statement: %-21.21s Line: %u\n",
1885 s, cstatement ? (char *)cstatement : _("unknown"),
1886 sline);
1887 fflush (cobsetptr->cob_trace_file);
1888 }
1889 }
1890
1891 /* cob_trace_section is kept for backward compatibility, but should be eventually removed */
1892 void
cob_trace_section(const char * para,const char * source,const int line)1893 cob_trace_section (const char *para, const char *source, const int line)
1894 {
1895 const char *s;
1896
1897 if (cobsetptr->cob_line_trace) {
1898 if (!cobsetptr->cob_trace_file) {
1899 cob_check_trace_file ();
1900 #if _MSC_VER /* fix dumb warning */
1901 if (!cobsetptr->cob_trace_file) {
1902 return;
1903 }
1904 #endif
1905 }
1906 if (source &&
1907 (!cob_last_sfile || strcmp (cob_last_sfile, source))) {
1908 if (cob_last_sfile) {
1909 cob_free ((void *)cob_last_sfile);
1910 }
1911 cob_last_sfile = cob_strdup (source);
1912 fprintf (cobsetptr->cob_trace_file, "Source: '%s'\n", source);
1913 }
1914 if (COB_MODULE_PTR && COB_MODULE_PTR->module_name) {
1915 s = COB_MODULE_PTR->module_name;
1916 } else {
1917 s = _("unknown");
1918 }
1919 fprintf (cobsetptr->cob_trace_file, "Program-Id: %-16s ", s);
1920 if (line) {
1921 fprintf (cobsetptr->cob_trace_file, "%-34.34sLine: %d\n", para, line);
1922 } else {
1923 fprintf (cobsetptr->cob_trace_file, "%s\n", para);
1924 }
1925 fflush (cobsetptr->cob_trace_file);
1926 }
1927 }
1928
1929 /* New routines for handling 'trace' follow */
1930 /* Note: As oposed to the old tracing these functions are only called
1931 if the following vars are set:
1932 COB_MODULE_PTR + ->module_stmt + ->module_sources
1933 */
1934 static int
cob_trace_prep(void)1935 cob_trace_prep (void)
1936 {
1937 const char *s;
1938 cob_current_program_id = COB_MODULE_PTR->module_name;
1939 if (COB_MODULE_PTR->module_stmt != 0
1940 && COB_MODULE_PTR->module_sources) {
1941 cob_source_file =
1942 COB_MODULE_PTR->module_sources[COB_GET_FILE_NUM(COB_MODULE_PTR->module_stmt)];
1943 cob_source_line = COB_GET_LINE_NUM(COB_MODULE_PTR->module_stmt);
1944 }
1945 if (!cobsetptr->cob_trace_file) {
1946 cob_check_trace_file ();
1947 if (!cobsetptr->cob_trace_file)
1948 return 1; /* silence warnings */
1949 }
1950 if (cob_source_file
1951 && (!cob_last_sfile || strcmp (cob_last_sfile, cob_source_file))) {
1952 if (cob_last_sfile) {
1953 cob_free ((void *)cob_last_sfile);
1954 }
1955 cob_last_sfile = cob_strdup (cob_source_file);
1956 fprintf (cobsetptr->cob_trace_file, "Source: '%s'\n", cob_source_file);
1957 }
1958 if (COB_MODULE_PTR->module_name) {
1959 s = COB_MODULE_PTR->module_name;
1960 } else {
1961 s = _("unknown");
1962 }
1963 if (!cob_last_progid
1964 || strcmp (cob_last_progid, s)) {
1965 cob_last_progid = s;
1966 if (COB_MODULE_PTR->module_type == COB_MODULE_TYPE_FUNCTION) {
1967 fprintf (cobsetptr->cob_trace_file, "Function-Id: %s\n", cob_last_progid);
1968 } else {
1969 fprintf (cobsetptr->cob_trace_file, "Program-Id: %s\n", cob_last_progid);
1970 }
1971 }
1972 return 0;
1973 }
1974
1975 static void
cob_trace_print(char * val)1976 cob_trace_print (char *val)
1977 {
1978 int i;
1979 int last_pos = (int)(strlen (cobsetptr->cob_trace_format) - 1);
1980
1981 for (i=0; cobsetptr->cob_trace_format[i] != 0; i++) {
1982 if (cobsetptr->cob_trace_format[i] == '%') {
1983 i++;
1984 if (toupper(cobsetptr->cob_trace_format[i]) == 'P') {
1985 if (COB_MODULE_PTR && COB_MODULE_PTR->module_type == COB_MODULE_TYPE_FUNCTION) {
1986 if (i != last_pos) {
1987 fprintf (cobsetptr->cob_trace_file, "Function-Id: %-16s", cob_last_progid);
1988 } else {
1989 fprintf (cobsetptr->cob_trace_file, "Function-Id: %s", cob_last_progid);
1990 }
1991 } else {
1992 if (i != last_pos) {
1993 fprintf (cobsetptr->cob_trace_file, "Program-Id: %-16s", cob_last_progid);
1994 } else {
1995 fprintf (cobsetptr->cob_trace_file, "Program-Id: %s", cob_last_progid);
1996 }
1997 }
1998 } else
1999 if (toupper(cobsetptr->cob_trace_format[i]) == 'I') {
2000 fprintf (cobsetptr->cob_trace_file, "%s", cob_last_progid);
2001 } else
2002 if (toupper(cobsetptr->cob_trace_format[i]) == 'L') {
2003 fprintf (cobsetptr->cob_trace_file, "%6u", cob_source_line);
2004 } else
2005 if (toupper(cobsetptr->cob_trace_format[i]) == 'S') {
2006 if (i != last_pos) {
2007 fprintf (cobsetptr->cob_trace_file, "%-42.42s", val);
2008 } else {
2009 fprintf (cobsetptr->cob_trace_file, "%s", val);
2010 }
2011 } else
2012 if (toupper(cobsetptr->cob_trace_format[i]) == 'F') {
2013 if (i != last_pos) {
2014 fprintf (cobsetptr->cob_trace_file, "Source: %-*.*s",
2015 -COB_MAX_NAMELEN, COB_MAX_NAMELEN, cob_last_sfile);
2016 } else {
2017 fprintf (cobsetptr->cob_trace_file, "Source: %s", cob_last_sfile);
2018 }
2019 }
2020 } else {
2021 fputc (cobsetptr->cob_trace_format[i], cobsetptr->cob_trace_file);
2022 }
2023 }
2024 fputc ('\n', cobsetptr->cob_trace_file);
2025 fflush (cobsetptr->cob_trace_file);
2026 }
2027
2028 void
cob_trace_sect(const char * name)2029 cob_trace_sect (const char *name)
2030 {
2031 char val[60];
2032
2033 /* store for CHECKME */
2034 cob_current_section = name;
2035
2036 /* actual tracing, if activated */
2037 if (cobsetptr->cob_line_trace
2038 && (COB_MODULE_PTR->flag_debug_trace & COB_MODULE_TRACE)) {
2039 if (cob_trace_prep()
2040 || name == NULL) {
2041 return;
2042 }
2043 snprintf (val, sizeof (val), " Section: %s", name);
2044 cob_trace_print (val);
2045 return;
2046 }
2047
2048 /* store for CHECKME */
2049 if (COB_MODULE_PTR->module_stmt != 0
2050 && COB_MODULE_PTR->module_sources) {
2051 cob_current_program_id = COB_MODULE_PTR->module_name;
2052 cob_source_file =
2053 COB_MODULE_PTR->module_sources[COB_GET_FILE_NUM(COB_MODULE_PTR->module_stmt)];
2054 cob_source_line = COB_GET_LINE_NUM(COB_MODULE_PTR->module_stmt);
2055 }
2056 }
2057
2058 void
cob_trace_para(const char * name)2059 cob_trace_para (const char *name)
2060 {
2061 char val[60];
2062
2063 /* store for CHECKME */
2064 cob_current_paragraph = name;
2065
2066 /* actual tracing, if activated */
2067 if (cobsetptr->cob_line_trace
2068 && (COB_MODULE_PTR->flag_debug_trace & COB_MODULE_TRACE)) {
2069 if (cob_trace_prep()
2070 || name == NULL) {
2071 return;
2072 }
2073 snprintf (val, sizeof (val), "Paragraph: %s", name);
2074 cob_trace_print (val);
2075 return;
2076 }
2077
2078 /* store for CHECKME */
2079 if (COB_MODULE_PTR->module_stmt != 0
2080 && COB_MODULE_PTR->module_sources) {
2081 cob_current_program_id = COB_MODULE_PTR->module_name;
2082 cob_source_file =
2083 COB_MODULE_PTR->module_sources[COB_GET_FILE_NUM(COB_MODULE_PTR->module_stmt)];
2084 cob_source_line = COB_GET_LINE_NUM(COB_MODULE_PTR->module_stmt);
2085 }
2086 }
2087
2088 void
cob_trace_entry(const char * name)2089 cob_trace_entry (const char *name)
2090 {
2091 char val[60];
2092
2093 /* actual tracing, if activated */
2094 if (cobsetptr->cob_line_trace
2095 && (COB_MODULE_PTR->flag_debug_trace & COB_MODULE_TRACE)) {
2096 if (cob_trace_prep()
2097 || name == NULL) {
2098 return;
2099 }
2100 snprintf (val, sizeof (val), " Entry: %s", name);
2101 cob_trace_print (val);
2102 return;
2103 }
2104
2105 /* store for CHECKME */
2106 if (COB_MODULE_PTR->module_stmt != 0
2107 && COB_MODULE_PTR->module_sources) {
2108 cob_current_program_id = COB_MODULE_PTR->module_name;
2109 cob_source_file =
2110 COB_MODULE_PTR->module_sources[COB_GET_FILE_NUM(COB_MODULE_PTR->module_stmt)];
2111 cob_source_line = COB_GET_LINE_NUM(COB_MODULE_PTR->module_stmt);
2112 }
2113 }
2114
2115 void
cob_trace_exit(const char * name)2116 cob_trace_exit (const char *name)
2117 {
2118 char val[60];
2119
2120 /* actual tracing, if activated */
2121 if (cobsetptr->cob_line_trace
2122 && (COB_MODULE_PTR->flag_debug_trace & COB_MODULE_TRACE)) {
2123 if (cob_trace_prep()
2124 || name == NULL) {
2125 return;
2126 }
2127 snprintf (val, sizeof (val), " Exit: %s", name);
2128 cob_trace_print (val);
2129 return;
2130 }
2131
2132 /* store for CHECKME */
2133 if (COB_MODULE_PTR->module_stmt != 0
2134 && COB_MODULE_PTR->module_sources) {
2135 cob_current_program_id = COB_MODULE_PTR->module_name;
2136 cob_source_file =
2137 COB_MODULE_PTR->module_sources[COB_GET_FILE_NUM(COB_MODULE_PTR->module_stmt)];
2138 cob_source_line = COB_GET_LINE_NUM(COB_MODULE_PTR->module_stmt);
2139 }
2140 }
2141
2142 void
cob_trace_stmt(const char * stmt)2143 cob_trace_stmt (const char *stmt)
2144 {
2145 char val[60];
2146
2147 /* store for CHECKME */
2148 if (stmt) {
2149 cob_source_statement = stmt;
2150 }
2151
2152 /* actual tracing, if activated */
2153 if (cobsetptr->cob_line_trace
2154 && (COB_MODULE_PTR->flag_debug_trace & COB_MODULE_TRACEALL)) {
2155 if (cob_trace_prep ()) {
2156 return;
2157 }
2158 snprintf (val, sizeof (val), " %s", stmt ? (char *)stmt : _("unknown"));
2159 cob_trace_print (val);
2160 return;
2161 }
2162
2163 /* store for CHECKME */
2164 if (COB_MODULE_PTR->module_stmt != 0
2165 && COB_MODULE_PTR->module_sources) {
2166 cob_current_program_id = COB_MODULE_PTR->module_name;
2167 cob_source_file =
2168 COB_MODULE_PTR->module_sources[COB_GET_FILE_NUM(COB_MODULE_PTR->module_stmt)];
2169 cob_source_line = COB_GET_LINE_NUM(COB_MODULE_PTR->module_stmt);
2170 }
2171 }
2172
2173 void
cob_nop(void)2174 cob_nop (void)
2175 {
2176 /* this is only an empty function, a call to it may be inserted by cobc
2177 to force some optimizations in the C compiler to not be triggered in
2178 a quite portable way */
2179 ;
2180 }
2181
2182 void
cob_ready_trace(void)2183 cob_ready_trace (void)
2184 {
2185 cobsetptr->cob_line_trace = 1;
2186 }
2187
2188 void
cob_reset_trace(void)2189 cob_reset_trace (void)
2190 {
2191 cobsetptr->cob_line_trace = 0;
2192 }
2193
2194 unsigned char *
cob_get_pointer(const void * srcptr)2195 cob_get_pointer (const void *srcptr)
2196 {
2197 void *tmptr;
2198
2199 memcpy (&tmptr, srcptr, sizeof (void *));
2200 return (cob_u8_ptr)tmptr;
2201 }
2202
2203 void
cob_field_to_string(const cob_field * f,void * str,const size_t maxsize)2204 cob_field_to_string (const cob_field *f, void *str, const size_t maxsize)
2205 {
2206 unsigned char *s;
2207 size_t count;
2208 size_t i;
2209
2210 if (unlikely (f == NULL)) {
2211 strncpy (str, _("NULL field"), maxsize);
2212 return;
2213 }
2214
2215 count = 0;
2216 if (unlikely (f->size == 0)) {
2217 return;
2218 }
2219 /* check if field has data assigned (may be a BASED / LINKAGE item) */
2220 if (unlikely (f->data == NULL)) {
2221 strncpy (str, _("field with NULL address"), maxsize);
2222 return;
2223 }
2224 for (i = f->size - 1; ; i--) {
2225 if (f->data[i] && f->data[i] != (unsigned char)' ') {
2226 count = i + 1;
2227 break;
2228 }
2229 if (!i) {
2230 break;
2231 }
2232 }
2233 if (count > maxsize) {
2234 count = maxsize;
2235 }
2236 s = (unsigned char *)str;
2237 for (i = 0; i < count; ++i) {
2238 s[i] = f->data[i];
2239 }
2240 s[i] = 0;
2241 }
2242
2243 void
cob_stop_run(const int status)2244 cob_stop_run (const int status)
2245 {
2246 struct exit_handlerlist *h;
2247
2248 if (!cob_initialized) {
2249 exit (EXIT_FAILURE);
2250 }
2251
2252 if (exit_hdlrs != NULL) {
2253 h = exit_hdlrs;
2254 while (h != NULL) {
2255 h->proc ();
2256 h = h->next;
2257 }
2258 }
2259 cob_terminate_routines ();
2260 exit (status);
2261 }
2262
2263 int
cob_is_initialized(void)2264 cob_is_initialized (void)
2265 {
2266 return (cobglobptr != NULL);
2267 }
2268
2269 cob_global *
cob_get_global_ptr(void)2270 cob_get_global_ptr (void)
2271 {
2272 /* LCOV_EXCL_START */
2273 if (unlikely (!cob_initialized)) {
2274 cob_fatal_error (COB_FERROR_INITIALIZED);
2275 }
2276 /* LCOV_EXCL_STOP */
2277 return cobglobptr;
2278 }
2279
2280 int
cob_module_global_enter(cob_module ** module,cob_global ** mglobal,const int auto_init,const int entry,const unsigned int * name_hash)2281 cob_module_global_enter (cob_module **module, cob_global **mglobal,
2282 const int auto_init, const int entry, const unsigned int *name_hash)
2283 {
2284 cob_module *mod;
2285 const int MAX_ITERS = 10240;
2286 int k;
2287 struct cob_alloc_module *mod_ptr;
2288
2289
2290 /* Check initialized */
2291 if (unlikely (!cob_initialized)) {
2292 if (auto_init) {
2293 cob_init (0, NULL);
2294 } else {
2295 cob_fatal_error (COB_FERROR_INITIALIZED);
2296 }
2297 }
2298
2299 /* Set global pointer */
2300 *mglobal = cobglobptr;
2301
2302 #if 0 /* cob_call_name_hash and cob_call_from_c are rw-branch only features
2303 for now - TODO: activate on merge of r1547 */
2304 /* Was caller a COBOL module */
2305 if (name_hash != NULL
2306 && cobglobptr->cob_call_name_hash != 0) {
2307 cobglobptr->cob_call_from_c = 1;
2308 k = 0;
2309 while (*name_hash != 0) { /* Scan table of values */
2310 if (cobglobptr->cob_call_name_hash == *name_hash) {
2311 cobglobptr->cob_call_from_c = 0;
2312 break;
2313 }
2314 name_hash++;
2315 k++;
2316 }
2317 }
2318 #else
2319 /* LCOV_EXCL_LINE */
2320 COB_UNUSED(name_hash);
2321 #endif
2322
2323 /* Check module pointer */
2324 if (!*module) {
2325 *module = cob_cache_malloc (sizeof (cob_module));
2326 /* Add to list of all modules activated */
2327 mod_ptr = cob_malloc (sizeof (struct cob_alloc_module));
2328 mod_ptr->cob_pointer = *module;
2329 mod_ptr->next = cob_module_list;
2330 cob_module_list = mod_ptr;
2331 #if 0 /* cob_call_name_hash and cob_call_from_c are rw-branch only features
2332 for now - TODO: activate on merge of r1547 */
2333 } else if (entry == 0
2334 && !cobglobptr->cob_call_from_c) {
2335 #else
2336 } else if (entry == 0) {
2337 #endif
2338 for (k = 0, mod = COB_MODULE_PTR; mod && k < MAX_ITERS; mod = mod->next, k++) {
2339 if (*module == mod) {
2340 if (cobglobptr->cob_stmt_exception) {
2341 /* CALL has ON EXCEPTION so return to caller */
2342 cob_set_exception (COB_EC_PROGRAM_RECURSIVE_CALL);
2343 cobglobptr->cob_stmt_exception = 0;
2344 return 1;
2345 }
2346 cob_module_err = mod;
2347 cob_fatal_error (COB_FERROR_RECURSIVE);
2348 }
2349 }
2350 }
2351
2352 /* Save parameter count, get number from argc if main program */
2353 if (!COB_MODULE_PTR) {
2354 cobglobptr->cob_call_params = cob_argc - 1;
2355 }
2356
2357 (*module)->module_num_params = cobglobptr->cob_call_params;
2358
2359 /* Push module pointer */
2360 (*module)->next = COB_MODULE_PTR;
2361 COB_MODULE_PTR = *module;
2362 COB_MODULE_PTR->module_stmt = 0;
2363
2364 cobglobptr->cob_stmt_exception = 0;
2365 return 0;
2366 }
2367
2368 void
cob_module_enter(cob_module ** module,cob_global ** mglobal,const int auto_init)2369 cob_module_enter (cob_module **module, cob_global **mglobal,
2370 const int auto_init)
2371 {
2372 (void)cob_module_global_enter (module, mglobal, auto_init, 0, 0);
2373 }
2374
2375 void
cob_module_leave(cob_module * module)2376 cob_module_leave (cob_module *module)
2377 {
2378 COB_UNUSED (module);
2379 /* Pop module pointer */
2380 COB_MODULE_PTR = COB_MODULE_PTR->next;
2381 }
2382
2383 void
cob_module_free(cob_module ** module)2384 cob_module_free (cob_module **module)
2385 {
2386 struct cob_alloc_module *ptr, *prv;
2387 if (*module == NULL) {
2388 return;
2389 }
2390
2391 prv = NULL;
2392 /* Remove from list of all modules activated */
2393 for (ptr = cob_module_list; ptr; ptr = ptr->next) {
2394 if (ptr->cob_pointer == *module) {
2395 if (prv == NULL) {
2396 cob_module_list = ptr->next;
2397 } else {
2398 prv->next = ptr->next;
2399 }
2400 cob_free (ptr);
2401 break;
2402 }
2403 prv = ptr;
2404 }
2405
2406 #if 0 /* cob_module->param_buf and cob_module->param_field are rw-branch only features
2407 for now - TODO: activate on merge of r1547 */
2408 && !cobglobptr->cob_call_from_c
2409 if ((*module)->param_buf != NULL)
2410 cob_cache_free ((*module)->param_buf);
2411 if ((*module)->param_field != NULL)
2412 cob_cache_free ((*module)->param_field);
2413 #endif
2414 cob_cache_free (*module);
2415 *module = NULL;
2416 }
2417
2418 /* save module environment - returns an allocated cob_func_loc (free at cob_restore_func)
2419 and the intermediate return field (must be freed by caller) */
2420 struct cob_func_loc *
cob_save_func(cob_field ** savefld,const int params,const int eparams,...)2421 cob_save_func (cob_field **savefld, const int params,
2422 const int eparams, ...)
2423 {
2424 struct cob_func_loc *fl;
2425 int numparams;
2426
2427 if (unlikely (params > eparams)) {
2428 numparams = eparams;
2429 } else {
2430 numparams = params;
2431 }
2432
2433 /* Allocate return field */
2434 *savefld = cob_malloc (sizeof (cob_field));
2435
2436 /* Allocate save area */
2437 fl = cob_malloc (sizeof (struct cob_func_loc));
2438 fl->func_params = cob_malloc (sizeof (void *) * ((size_t)numparams + 1U));
2439 fl->data = cob_malloc (sizeof (void *) * ((size_t)numparams + 1U));
2440
2441 /* Save values */
2442 fl->save_module = COB_MODULE_PTR->next;
2443 fl->save_call_params = cobglobptr->cob_call_params;
2444 fl->save_proc_parms = COB_MODULE_PTR->cob_procedure_params;
2445 fl->save_num_params = COB_MODULE_PTR->module_num_params;
2446
2447 /* Set current values */
2448 COB_MODULE_PTR->cob_procedure_params = fl->func_params;
2449 cobglobptr->cob_call_params = numparams;
2450 if (numparams) {
2451 va_list args;
2452 int n;
2453 va_start (args, eparams);
2454 for (n = 0; n < numparams; ++n) {
2455 fl->func_params[n] = va_arg (args, cob_field *);
2456 if (fl->func_params[n]) {
2457 fl->data[n] = fl->func_params[n]->data;
2458 }
2459 }
2460 va_end (args);
2461 }
2462 return fl;
2463 }
2464
2465 /* restores module environment - frees the passed cob_func_loc */
2466 void
cob_restore_func(struct cob_func_loc * fl)2467 cob_restore_func (struct cob_func_loc *fl)
2468 {
2469 /* Restore calling environment */
2470 cobglobptr->cob_call_params = fl->save_call_params;
2471 #if 0 /* RXWRXW - MODNEXT */
2472 COB_MODULE_PTR->next = fl->save_module;
2473 #endif
2474 COB_MODULE_PTR->cob_procedure_params = fl->save_proc_parms;
2475 COB_MODULE_PTR->module_num_params = fl->save_num_params;
2476 cob_free (fl->data);
2477 cob_free (fl->func_params);
2478 cob_free (fl);
2479 }
2480
2481 struct ver_t {
2482 int major, minor, point;
2483 unsigned int version;
2484 };
2485
2486 /*
2487 * Convert version components to an integer value for comparison.
2488 */
2489 static COB_INLINE unsigned int
version_bitstring(const struct ver_t module)2490 version_bitstring( const struct ver_t module )
2491 {
2492 unsigned int version =
2493 ((unsigned int)module.major << 24) |
2494 ((unsigned int)module.minor << 16) |
2495 ((unsigned int)module.point << 8);
2496 return version;
2497 }
2498
2499 void
cob_check_version(const char * prog,const char * packver_prog,const int patchlev_prog)2500 cob_check_version (const char *prog,
2501 const char *packver_prog, const int patchlev_prog)
2502 {
2503 int nparts;
2504 struct ver_t lib = { 9, 9, 9 };
2505 struct ver_t app = { 0 };
2506
2507 nparts = sscanf (PACKAGE_VERSION, "%d.%d.%d",
2508 &lib.major, &lib.minor, &lib.point);
2509
2510 if (nparts >= 2) {
2511 lib.version = version_bitstring(lib);
2512
2513 (void)sscanf (packver_prog, "%d.%d.%d",
2514 &app.major, &app.minor, &app.point);
2515 app.version = version_bitstring(app);
2516
2517 if (app.version == lib.version
2518 && patchlev_prog <= PATCH_LEVEL) {
2519 return;
2520 } else
2521 if (app.major == 2 && app.minor < 2) {
2522 } else
2523 if (app.version < lib.version) {
2524 /* we only claim compatibility to 2.2+ */
2525 struct ver_t minimal = { 2, 2 };
2526 if (app.version <= version_bitstring (minimal)) {
2527 cannot_check_subscript = 1;
2528 }
2529 minimal.minor = 1;
2530 if (app.version >= version_bitstring (minimal)) {
2531 return;
2532 }
2533 }
2534 }
2535
2536 cob_runtime_error (_("version mismatch"));
2537 cob_runtime_hint (_("%s has version %s.%d"), prog,
2538 packver_prog, patchlev_prog);
2539 cob_runtime_hint (_("%s has version %s.%d"), "libcob",
2540 PACKAGE_VERSION, PATCH_LEVEL);
2541 cob_stop_run (1);
2542 }
2543
2544 void
cob_parameter_check(const char * func_name,const int num_arguments)2545 cob_parameter_check (const char *func_name, const int num_arguments)
2546 {
2547 if (cobglobptr->cob_call_params < num_arguments) {
2548 cob_runtime_error (_("CALL to %s requires %d arguments"),
2549 func_name, num_arguments);
2550 cob_stop_run (1);
2551 }
2552 }
2553
2554 void
cob_correct_numeric(cob_field * f)2555 cob_correct_numeric (cob_field *f)
2556 {
2557 unsigned char *p;
2558 unsigned char *data;
2559 size_t size;
2560 size_t i;
2561
2562 if (!COB_FIELD_IS_NUMDISP (f)) {
2563 return;
2564 }
2565 size = f->size;
2566 data = f->data;
2567 if (COB_FIELD_HAVE_SIGN (f)) {
2568 /* Adjust for sign byte */
2569 size--;
2570 if (unlikely (COB_FIELD_SIGN_LEADING (f))) {
2571 p = f->data;
2572 data = p + 1;
2573 } else {
2574 p = f->data + f->size - 1;
2575 }
2576 if (unlikely (COB_FIELD_SIGN_SEPARATE (f))) {
2577 if (*p != '+' && *p != '-') {
2578 *p = '+';
2579 }
2580 } else if (unlikely (COB_MODULE_PTR->ebcdic_sign)) {
2581 switch (*p) {
2582 case '{':
2583 case 'A':
2584 case 'B':
2585 case 'C':
2586 case 'D':
2587 case 'E':
2588 case 'F':
2589 case 'G':
2590 case 'H':
2591 case 'I':
2592 case '}':
2593 case 'J':
2594 case 'K':
2595 case 'L':
2596 case 'M':
2597 case 'N':
2598 case 'O':
2599 case 'P':
2600 case 'Q':
2601 case 'R':
2602 break;
2603 case '0':
2604 *p = '{';
2605 break;
2606 case '1':
2607 *p = 'A';
2608 break;
2609 case '2':
2610 *p = 'B';
2611 break;
2612 case '3':
2613 *p = 'C';
2614 break;
2615 case '4':
2616 *p = 'D';
2617 break;
2618 case '5':
2619 *p = 'E';
2620 break;
2621 case '6':
2622 *p = 'F';
2623 break;
2624 case '7':
2625 *p = 'G';
2626 break;
2627 case '8':
2628 *p = 'H';
2629 break;
2630 case '9':
2631 *p = 'I';
2632 break;
2633 case 0:
2634 case ' ':
2635 *p = '{';
2636 break;
2637 default:
2638 break;
2639 }
2640 } else {
2641 if (!*p || *p == ' ') {
2642 *p = '0';
2643 }
2644 }
2645 } else {
2646 p = f->data + f->size - 1;
2647 if (unlikely (COB_MODULE_PTR->ebcdic_sign)) {
2648 switch (*p) {
2649 case 0:
2650 case ' ':
2651 case '{':
2652 case '}':
2653 *p = '0';
2654 break;
2655 case 'A':
2656 case 'B':
2657 case 'C':
2658 case 'D':
2659 case 'E':
2660 case 'F':
2661 case 'G':
2662 case 'H':
2663 case 'I':
2664 *p = '1' + (*p - 'A');
2665 break;
2666 case 'J':
2667 case 'K':
2668 case 'L':
2669 case 'M':
2670 case 'N':
2671 case 'O':
2672 case 'P':
2673 case 'Q':
2674 case 'R':
2675 *p = '1' + (*p - 'J');
2676 break;
2677 default:
2678 break;
2679 }
2680 } else {
2681 switch (*p) {
2682 case 0:
2683 case ' ':
2684 case 'p':
2685 *p = '0';
2686 break;
2687 case 'q':
2688 *p = '1';
2689 break;
2690 case 'r':
2691 *p = '2';
2692 break;
2693 case 's':
2694 *p = '3';
2695 break;
2696 case 't':
2697 *p = '4';
2698 break;
2699 case 'u':
2700 *p = '5';
2701 break;
2702 case 'v':
2703 *p = '6';
2704 break;
2705 case 'w':
2706 *p = '7';
2707 break;
2708 case 'x':
2709 *p = '8';
2710 break;
2711 case 'y':
2712 *p = '9';
2713 break;
2714 default:
2715 break;
2716 }
2717 }
2718 }
2719 for (i = 0, p = data; i < size; ++i, ++p) {
2720 switch (*p) {
2721 case '0':
2722 case '1':
2723 case '2':
2724 case '3':
2725 case '4':
2726 case '5':
2727 case '6':
2728 case '7':
2729 case '8':
2730 case '9':
2731 break;
2732 case 0:
2733 case ' ':
2734 *p = '0';
2735 break;
2736 default:
2737 if ((*p & 0x0F) <= 9) {
2738 *p = (*p & 0x0F) + '0';
2739 }
2740 break;
2741 }
2742 }
2743 }
2744
2745 static int
cob_check_numdisp(const cob_field * f)2746 cob_check_numdisp (const cob_field *f)
2747 {
2748 unsigned char *p;
2749 unsigned char *data;
2750 size_t size;
2751 size_t i;
2752
2753 size = f->size;
2754 data = f->data;
2755 if (COB_FIELD_HAVE_SIGN (f)) {
2756 /* Adjust for sign byte */
2757 size--;
2758 if (unlikely (COB_FIELD_SIGN_LEADING (f))) {
2759 p = f->data;
2760 data = p + 1;
2761 } else {
2762 p = f->data + f->size - 1;
2763 }
2764 if (unlikely (COB_FIELD_SIGN_SEPARATE (f))) {
2765 if (*p != '+' && *p != '-') {
2766 return 0;
2767 }
2768 } else if (unlikely (COB_MODULE_PTR->ebcdic_sign)) {
2769 switch (*p) {
2770 case '0':
2771 case '1':
2772 case '2':
2773 case '3':
2774 case '4':
2775 case '5':
2776 case '6':
2777 case '7':
2778 case '8':
2779 case '9':
2780 case '{':
2781 case 'A':
2782 case 'B':
2783 case 'C':
2784 case 'D':
2785 case 'E':
2786 case 'F':
2787 case 'G':
2788 case 'H':
2789 case 'I':
2790 case '}':
2791 case 'J':
2792 case 'K':
2793 case 'L':
2794 case 'M':
2795 case 'N':
2796 case 'O':
2797 case 'P':
2798 case 'Q':
2799 case 'R':
2800 break;
2801 default:
2802 return 0;
2803 }
2804 } else {
2805 switch (*p) {
2806 case '0':
2807 case '1':
2808 case '2':
2809 case '3':
2810 case '4':
2811 case '5':
2812 case '6':
2813 case '7':
2814 case '8':
2815 case '9':
2816 case 'p':
2817 case 'q':
2818 case 'r':
2819 case 's':
2820 case 't':
2821 case 'u':
2822 case 'v':
2823 case 'w':
2824 case 'x':
2825 case 'y':
2826 break;
2827 default:
2828 return 0;
2829 }
2830 }
2831 }
2832 for (i = 0; i < size; ++i) {
2833 if (!isdigit (data[i])) {
2834 return 0;
2835 }
2836 }
2837 return 1;
2838 }
2839
2840 /* Sign */
2841
2842 int
cob_real_get_sign(cob_field * f)2843 cob_real_get_sign (cob_field *f)
2844 {
2845 unsigned char *p;
2846
2847 switch (COB_FIELD_TYPE (f)) {
2848 case COB_TYPE_NUMERIC_DISPLAY:
2849 /* Locate sign */
2850 if (unlikely (COB_FIELD_SIGN_LEADING (f))) {
2851 p = f->data;
2852 } else {
2853 p = f->data + f->size - 1;
2854 }
2855
2856 /* Get sign */
2857 if (unlikely (COB_FIELD_SIGN_SEPARATE (f))) {
2858 return (*p == '-') ? -1 : 1;
2859 }
2860 if (*p >= (unsigned char)'0' && *p <= (unsigned char)'9') {
2861 return 1;
2862 }
2863 if (*p == ' ') {
2864 #if 0 /* RXWRXW - Space sign */
2865 *p = (unsigned char)'0';
2866 #endif
2867 return 1;
2868 }
2869 if (unlikely (COB_MODULE_PTR->ebcdic_sign)) {
2870 return cob_get_sign_ebcdic (p);
2871 }
2872 return cob_get_sign_ascii (p);
2873 case COB_TYPE_NUMERIC_PACKED:
2874 if (COB_FIELD_NO_SIGN_NIBBLE (f)) {
2875 return 1;
2876 }
2877 p = f->data + f->size - 1;
2878 return ((*p & 0x0F) == 0x0D) ? -1 : 1;
2879 }
2880 return 0;
2881 }
2882
2883 void
cob_real_put_sign(cob_field * f,const int sign)2884 cob_real_put_sign (cob_field *f, const int sign)
2885 {
2886 unsigned char *p;
2887 unsigned char c;
2888
2889 switch (COB_FIELD_TYPE (f)) {
2890 case COB_TYPE_NUMERIC_DISPLAY:
2891 /* Locate sign */
2892 if (unlikely (COB_FIELD_SIGN_LEADING (f))) {
2893 p = f->data;
2894 } else {
2895 p = f->data + f->size - 1;
2896 }
2897
2898 /* Put sign */
2899 if (unlikely (COB_FIELD_SIGN_SEPARATE (f))) {
2900 c = (sign < 0) ? (cob_u8_t)'-' : (cob_u8_t)'+';
2901 if (*p != c) {
2902 *p = c;
2903 }
2904 } else if (unlikely (COB_MODULE_PTR->ebcdic_sign)) {
2905 cob_put_sign_ebcdic (p, sign);
2906 } else if (sign < 0) {
2907 cob_put_sign_ascii (p);
2908 }
2909 return;
2910 case COB_TYPE_NUMERIC_PACKED:
2911 if (COB_FIELD_NO_SIGN_NIBBLE (f)) {
2912 return;
2913 }
2914 p = f->data + f->size - 1;
2915 if (sign < 0) {
2916 *p = (*p & 0xF0) | 0x0D;
2917 } else {
2918 *p = (*p & 0xF0) | 0x0C;
2919 }
2920 return;
2921 }
2922 }
2923
2924 /* Registration of external handlers */
2925 void
cob_reg_sighnd(void (* sighnd)(int))2926 cob_reg_sighnd (void (*sighnd) (int))
2927 {
2928 if (!cob_initialized) {
2929 cob_set_signal ();
2930 }
2931 cob_ext_sighdl = sighnd;
2932 }
2933
2934 /* Switch */
2935
2936 int
cob_get_switch(const int n)2937 cob_get_switch (const int n)
2938 {
2939 if (n < 0 || n > COB_SWITCH_MAX) {
2940 return 0;
2941 }
2942 return cob_switch[n];
2943 }
2944
2945 void
cob_set_switch(const int n,const int flag)2946 cob_set_switch (const int n, const int flag)
2947 {
2948 if (n < 0 || n > COB_SWITCH_MAX) {
2949 return;
2950 }
2951 if (flag == 0) {
2952 cob_switch[n] = 0;
2953 } else if (flag == 1) {
2954 cob_switch[n] = 1;
2955 }
2956 }
2957
2958 int
cob_cmp(cob_field * f1,cob_field * f2)2959 cob_cmp (cob_field *f1, cob_field *f2)
2960 {
2961 cob_field temp;
2962 cob_field_attr attr;
2963 unsigned char buff[256];
2964
2965 if (COB_FIELD_IS_NUMERIC (f1) && COB_FIELD_IS_NUMERIC (f2)) {
2966 return cob_numeric_cmp (f1, f2);
2967 }
2968 if (COB_FIELD_TYPE (f2) == COB_TYPE_ALPHANUMERIC_ALL) {
2969 if (f2->size == 1 && f2->data[0] == '0' &&
2970 COB_FIELD_IS_NUMERIC (f1)) {
2971 return cob_cmp_int (f1, 0);
2972 }
2973 return cob_cmp_all (f1, f2);
2974 }
2975 if (COB_FIELD_TYPE (f1) == COB_TYPE_ALPHANUMERIC_ALL) {
2976 if (f1->size == 1 && f1->data[0] == '0' &&
2977 COB_FIELD_IS_NUMERIC (f2)) {
2978 return -cob_cmp_int (f2, 0);
2979 }
2980 return -cob_cmp_all (f2, f1);
2981 }
2982 if (COB_FIELD_IS_NUMERIC (f1) &&
2983 COB_FIELD_TYPE (f1) != COB_TYPE_NUMERIC_DISPLAY) {
2984 temp.size = COB_FIELD_DIGITS (f1);
2985 temp.data = buff;
2986 temp.attr = &attr;
2987 attr = *f1->attr;
2988 attr.type = COB_TYPE_NUMERIC_DISPLAY;
2989 attr.flags &= ~COB_FLAG_HAVE_SIGN;
2990 cob_move (f1, &temp);
2991 f1 = &temp;
2992 }
2993 if (COB_FIELD_IS_NUMERIC (f2) &&
2994 COB_FIELD_TYPE (f2) != COB_TYPE_NUMERIC_DISPLAY) {
2995 temp.size = COB_FIELD_DIGITS (f2);
2996 temp.data = buff;
2997 temp.attr = &attr;
2998 attr = *f2->attr;
2999 attr.type = COB_TYPE_NUMERIC_DISPLAY;
3000 attr.flags &= ~COB_FLAG_HAVE_SIGN;
3001 cob_move (f2, &temp);
3002 f2 = &temp;
3003 }
3004 return cob_cmp_alnum (f1, f2);
3005 }
3006
3007 /* Class check */
3008
3009 int
cob_is_omitted(const cob_field * f)3010 cob_is_omitted (const cob_field *f)
3011 {
3012 return f->data == NULL;
3013 }
3014
3015 int
cob_is_numeric(const cob_field * f)3016 cob_is_numeric (const cob_field *f)
3017 {
3018 size_t i;
3019 union {
3020 float fpf;
3021 double fpd;
3022 } fval;
3023 int sign;
3024
3025 switch (COB_FIELD_TYPE (f)) {
3026 case COB_TYPE_NUMERIC_BINARY:
3027 return 1;
3028 case COB_TYPE_NUMERIC_FLOAT:
3029 memcpy (&fval.fpf, f->data, sizeof (float));
3030 return !ISFINITE ((double)fval.fpf);
3031 case COB_TYPE_NUMERIC_DOUBLE:
3032 memcpy (&fval.fpd, f->data, sizeof (double));
3033 return !ISFINITE (fval.fpd);
3034 case COB_TYPE_NUMERIC_PACKED:
3035 /* Check digits */
3036 for (i = 0; i < f->size - 1; ++i) {
3037 if ((f->data[i] & 0xF0) > 0x90 ||
3038 (f->data[i] & 0x0F) > 0x09) {
3039 return 0;
3040 }
3041 }
3042 /* Check high nibble of last byte */
3043 if ((f->data[i] & 0xF0) > 0x90) {
3044 return 0;
3045 }
3046
3047 if (COB_FIELD_NO_SIGN_NIBBLE (f)) {
3048 /* COMP-6 - Check last nibble */
3049 if ((f->data[i] & 0x0F) > 0x09) {
3050 return 0;
3051 }
3052 return 1;
3053 }
3054
3055 /* Check sign */
3056 sign = f->data[i] & 0x0F;
3057 if (COB_FIELD_HAVE_SIGN (f)) {
3058 if (sign == 0x0C || sign == 0x0D) {
3059 return 1;
3060 }
3061 if (COB_MODULE_PTR->flag_host_sign &&
3062 sign == 0x0F) {
3063 return 1;
3064 }
3065 } else if (sign == 0x0F) {
3066 return 1;
3067 }
3068 return 0;
3069 case COB_TYPE_NUMERIC_DISPLAY:
3070 return cob_check_numdisp (f);
3071 case COB_TYPE_NUMERIC_FP_DEC64:
3072 #ifdef WORDS_BIGENDIAN
3073 return (f->data[0] & 0x78U) != 0x78U;
3074 #else
3075 return (f->data[7] & 0x78U) != 0x78U;
3076 #endif
3077 case COB_TYPE_NUMERIC_FP_DEC128:
3078 #ifdef WORDS_BIGENDIAN
3079 return (f->data[0] & 0x78U) != 0x78U;
3080 #else
3081 return (f->data[15] & 0x78U) != 0x78U;
3082 #endif
3083 default:
3084 for (i = 0; i < f->size; ++i) {
3085 if (!isdigit (f->data[i])) {
3086 return 0;
3087 }
3088 }
3089 return 1;
3090 }
3091 }
3092
3093 int
cob_is_alpha(const cob_field * f)3094 cob_is_alpha (const cob_field *f)
3095 {
3096 size_t i;
3097
3098 for (i = 0; i < f->size; ++i) {
3099 if (!isalpha (f->data[i]) && f->data[i] != (unsigned char)' ') {
3100 return 0;
3101 }
3102 }
3103 return 1;
3104 }
3105
3106 int
cob_is_upper(const cob_field * f)3107 cob_is_upper (const cob_field *f)
3108 {
3109 size_t i;
3110
3111 for (i = 0; i < f->size; ++i) {
3112 if (!isupper (f->data[i]) && f->data[i] != (unsigned char)' ') {
3113 return 0;
3114 }
3115 }
3116 return 1;
3117 }
3118
3119 int
cob_is_lower(const cob_field * f)3120 cob_is_lower (const cob_field *f)
3121 {
3122 size_t i;
3123
3124 for (i = 0; i < f->size; ++i) {
3125 if (!islower (f->data[i]) && f->data[i] != (unsigned char)' ') {
3126 return 0;
3127 }
3128 }
3129 return 1;
3130 }
3131
3132 /* Table sort */
3133
3134 void
cob_table_sort_init(const size_t nkeys,const unsigned char * collating_sequence)3135 cob_table_sort_init (const size_t nkeys, const unsigned char *collating_sequence)
3136 {
3137 sort_nkeys = 0;
3138 sort_keys = cob_malloc (nkeys * sizeof (cob_file_key));
3139 if (collating_sequence) {
3140 sort_collate = collating_sequence;
3141 } else {
3142 sort_collate = COB_MODULE_PTR->collating_sequence;
3143 }
3144 }
3145
3146 void
cob_table_sort_init_key(cob_field * field,const int flag,const unsigned int offset)3147 cob_table_sort_init_key (cob_field *field, const int flag,
3148 const unsigned int offset)
3149 {
3150 sort_keys[sort_nkeys].field = field;
3151 sort_keys[sort_nkeys].flag = flag;
3152 sort_keys[sort_nkeys].offset = offset;
3153 sort_nkeys++;
3154 }
3155
3156 void
cob_table_sort(cob_field * f,const int n)3157 cob_table_sort (cob_field *f, const int n)
3158 {
3159 qsort (f->data, (size_t) n, f->size, sort_compare);
3160 cob_free (sort_keys);
3161 }
3162
3163 /* Run-time error checking */
3164
3165 void
cob_check_based(const unsigned char * x,const char * name)3166 cob_check_based (const unsigned char *x, const char *name)
3167 {
3168 if (!x) {
3169 /* name includes '' already and can be ... 'x' (addressed by 'y') */
3170 cob_runtime_error (_("BASED/LINKAGE item %s has NULL address"), name);
3171 cob_stop_run (1);
3172 }
3173 }
3174
3175 void
cob_check_linkage(const unsigned char * x,const char * name,const int check_type)3176 cob_check_linkage (const unsigned char *x, const char *name, const int check_type)
3177 {
3178 if (!x) {
3179 /* name includes '' already and can be ... 'x' of 'y' */
3180 switch (check_type) {
3181 case 0: /* check for passed items and size on module entry */
3182 cob_runtime_error (_("LINKAGE item %s not passed by caller"), name);
3183 break;
3184 case 1: /* check for passed OPTIONAL items on item use */
3185 cob_runtime_error (_("LINKAGE item %s not passed by caller"), name);
3186 break;
3187 }
3188 cob_stop_run (1);
3189 }
3190 }
3191
3192 const char *
explain_field_type(const cob_field * f)3193 explain_field_type (const cob_field *f)
3194 {
3195 switch (COB_FIELD_TYPE (f)) {
3196 case COB_TYPE_GROUP:
3197 return "GROUP";
3198 case COB_TYPE_BOOLEAN:
3199 return "BOOLEAN";
3200 case COB_TYPE_NUMERIC_DISPLAY:
3201 return "NUMERIC DISPLAY";
3202 case COB_TYPE_NUMERIC_BINARY:
3203 return "BINARY";
3204 case COB_TYPE_NUMERIC_PACKED:
3205 return "PACKED-DECIMAL";
3206 case COB_TYPE_NUMERIC_FLOAT:
3207 return "FLOAT";
3208 case COB_TYPE_NUMERIC_DOUBLE:
3209 return "DOUBLE";
3210 case COB_TYPE_NUMERIC_L_DOUBLE:
3211 return "LONG DOUBLE";
3212 case COB_TYPE_NUMERIC_FP_DEC64:
3213 return "FP DECIMAL 64";
3214 case COB_TYPE_NUMERIC_FP_DEC128:
3215 return "FP DECIMAL 128";
3216 case COB_TYPE_NUMERIC_FP_BIN32:
3217 return "FP BINARY 32";
3218 case COB_TYPE_NUMERIC_FP_BIN64:
3219 return "FP BINARY 64";
3220 case COB_TYPE_NUMERIC_FP_BIN128:
3221 return "FP BINARY 128";
3222 /* note: may be not reached depending on endianness */
3223 case COB_TYPE_NUMERIC_COMP5:
3224 return "COMP-5";
3225 case COB_TYPE_NUMERIC_EDITED:
3226 return "NUMERIC EDITED";
3227 case COB_TYPE_ALPHANUMERIC:
3228 return "ALPHANUMERIC";
3229 case COB_TYPE_ALPHANUMERIC_ALL:
3230 return "ALPHANUMERIC ALL";
3231 case COB_TYPE_ALPHANUMERIC_EDITED:
3232 return "ALPHANUMERIC EDITED";
3233 case COB_TYPE_NATIONAL:
3234 return "NATIONAL";
3235 case COB_TYPE_NATIONAL_EDITED:
3236 return "NATIONAL EDITED";
3237 default:
3238 break;
3239 }
3240 return "UNKNOWN";
3241 }
3242
3243 void
cob_check_numeric(const cob_field * f,const char * name)3244 cob_check_numeric (const cob_field *f, const char *name)
3245 {
3246 unsigned char *data;
3247 char *p;
3248 char *buff;
3249 size_t i;
3250
3251 if (!cob_is_numeric (f)) {
3252 cob_set_exception (COB_EC_DATA_INCOMPATIBLE);
3253 buff = cob_fast_malloc ((size_t)COB_SMALL_BUFF);
3254 p = buff;
3255 data = f->data;
3256 if (COB_FIELD_IS_NUMDISP(f) || COB_FIELD_IS_ANY_ALNUM(f)) {
3257 for (i = 0; i < f->size; ++i) {
3258 if (isprint (data[i])) {
3259 *p++ = data[i];
3260 } else {
3261 p += sprintf (p, "\\%03o", data[i]);
3262 }
3263 }
3264 } else {
3265 p += sprintf (p, "0x");
3266 for (i = 0; i < f->size; ++i) {
3267 p += sprintf (p, "%02x", data[i]);
3268 }
3269 }
3270 *p = '\0';
3271 cob_runtime_error (_("'%s' (Type: %s) not numeric: '%s'"),
3272 name, explain_field_type(f), buff);
3273 cob_free (buff);
3274 cob_stop_run (1);
3275 }
3276 }
3277
3278 void
cob_check_odo(const int i,const int min,const int max,const char * name,const char * dep_name)3279 cob_check_odo (const int i, const int min,
3280 const int max, const char *name, const char *dep_name)
3281 {
3282 /* Check OCCURS DEPENDING ON item */
3283 if (i < min || i > max) {
3284 cob_set_exception (COB_EC_BOUND_ODO);
3285
3286 /* Hack for call from 2.0 modules as the module signature was changed :-(
3287 Note: depending on the actual C runtime this may work or directly break
3288 */
3289 /* LCOV_EXCL_START */
3290 if (dep_name == NULL) {
3291 dep_name = name;
3292 name = "unknown field";
3293 }
3294 /* LCOV_EXCL_STOP */
3295
3296 cob_runtime_error (_("OCCURS DEPENDING ON '%s' out of bounds: %d"),
3297 dep_name, i);
3298 if (i > max) {
3299 cob_runtime_hint (_("maximum subscript for '%s': %d"), name, max);
3300 } else {
3301 cob_runtime_hint (_("minimum subscript for '%s': %d"), name, min);
3302 }
3303 cob_stop_run (1);
3304 }
3305 }
3306
3307 void
cob_check_subscript(const int i,const int max,const char * name,const int odo_item)3308 cob_check_subscript (const int i, const int max,
3309 const char *name, const int odo_item)
3310 {
3311 #if 1
3312 /* Hack for call from 2.0 modules as the module signature was changed :-(
3313 Note: depending on the actual C runtime this may work or directly break
3314 */
3315 /* LCOV_EXCL_START */
3316 if (cannot_check_subscript) {
3317 /* Check zero subscript */
3318 if (i == 0) {
3319 cob_set_exception (COB_EC_BOUND_SUBSCRIPT);
3320 cob_runtime_error (_("subscript of '%s' out of bounds: %d"), "unknown field", i);
3321 cob_stop_run (1);
3322 }
3323 return;
3324 }
3325 /* LCOV_EXCL_STOP */
3326 #endif
3327
3328 /* Check subscript */
3329 if (i < 1 || i > max) {
3330 cob_set_exception (COB_EC_BOUND_SUBSCRIPT);
3331 cob_runtime_error (_("subscript of '%s' out of bounds: %d"), name, i);
3332 if (i >= 1) {
3333 if (odo_item) {
3334 cob_runtime_hint (_("current maximum subscript for '%s': %d"),
3335 name, max);
3336 } else {
3337 cob_runtime_hint (_("maximum subscript for '%s': %d"),
3338 name, max);
3339 }
3340 }
3341 cob_stop_run (1);
3342 }
3343 }
3344
3345 void
cob_check_ref_mod_detailed(const char * name,const int abend,const int zero_allowed,const int size,const int offset,const int length)3346 cob_check_ref_mod_detailed (const char *name, const int abend, const int zero_allowed,
3347 const int size, const int offset, const int length)
3348 {
3349 const int minimal_length = zero_allowed ? 0 : 1;
3350
3351 /* Check offset */
3352 if (offset < 1 || offset > size) {
3353 cob_set_exception (COB_EC_BOUND_REF_MOD);
3354 if (offset < 1) {
3355 cob_runtime_error (_("offset of '%s' out of bounds: %d"),
3356 name, offset);
3357 } else {
3358 cob_runtime_error (_("offset of '%s' out of bounds: %d, maximum: %d"),
3359 name, offset, size);
3360 }
3361 if (abend) {
3362 cob_stop_run (1);
3363 }
3364 }
3365
3366 /* Check plain length */
3367 if (length < minimal_length || length > size) {
3368 cob_set_exception (COB_EC_BOUND_REF_MOD);
3369 if (length < minimal_length) {
3370 cob_runtime_error (_("length of '%s' out of bounds: %d"),
3371 name, length);
3372 } else {
3373 cob_runtime_error (_("length of '%s' out of bounds: %d, maximum: %d"),
3374 name, length, size);
3375 }
3376 if (abend) {
3377 cob_stop_run (1);
3378 }
3379 }
3380
3381 /* Check length with offset */
3382 if (offset + length - 1 > size) {
3383 cob_set_exception (COB_EC_BOUND_REF_MOD);
3384 cob_runtime_error (_("length of '%s' out of bounds: %d, starting at: %d, maximum: %d"),
3385 name, length, offset, size);
3386 if (abend) {
3387 cob_stop_run (1);
3388 }
3389 }
3390 }
3391
3392 /* kept for 2.2-3.1-rc1 compat only */
3393 void
cob_check_ref_mod(const int offset,const int length,const int size,const char * name)3394 cob_check_ref_mod (const int offset, const int length,
3395 const int size, const char* name)
3396 {
3397 cob_check_ref_mod_detailed (name, 1, 0, size, offset, length);
3398 }
3399
3400 void
cob_check_ref_mod_minimal(const char * name,const int offset,const int length)3401 cob_check_ref_mod_minimal (const char* name, const int offset, const int length)
3402 {
3403 /* Check offset */
3404 if (offset < 1) {
3405 cob_set_exception (COB_EC_BOUND_REF_MOD);
3406 cob_runtime_error (_("offset of '%s' out of bounds: %d"),
3407 name, offset);
3408 cob_stop_run (1);
3409 }
3410
3411 /* Check length */
3412 if (length < 1) {
3413 cob_set_exception (COB_EC_BOUND_REF_MOD);
3414 cob_runtime_error (_("length of '%s' out of bounds: %d"),
3415 name, length);
3416 cob_stop_run (1);
3417 }
3418 }
3419
3420 void *
cob_external_addr(const char * exname,const int exlength)3421 cob_external_addr (const char *exname, const int exlength)
3422 {
3423 struct cob_external *eptr;
3424
3425 /* special external "C" registers */
3426 if (exlength == sizeof (int)
3427 && !strcmp (exname, "ERRNO")) {
3428 return &errno;
3429 }
3430
3431 /* Locate or allocate EXTERNAL item */
3432 for (eptr = basext; eptr; eptr = eptr->next) {
3433 if (!strcmp (exname, eptr->ename)) {
3434 if (exlength > eptr->esize) {
3435 cob_runtime_error (_("EXTERNAL item '%s' previously allocated with size %d, requested size is %d"),
3436 exname, eptr->esize, exlength);
3437 cob_stop_run (1);
3438 }
3439 if (exlength < eptr->esize) {
3440 cob_runtime_warning (_("EXTERNAL item '%s' previously allocated with size %d, requested size is %d"),
3441 exname, eptr->esize, exlength);
3442 }
3443 cobglobptr->cob_initial_external = 0;
3444 return eptr->ext_alloc;
3445 }
3446 }
3447 eptr = cob_malloc (sizeof (struct cob_external));
3448 eptr->next = basext;
3449 eptr->esize = exlength;
3450 eptr->ename = cob_malloc (strlen (exname) + 1U);
3451 strcpy (eptr->ename, exname);
3452 eptr->ext_alloc = cob_malloc ((size_t)exlength);
3453 basext = eptr;
3454 cobglobptr->cob_initial_external = 1;
3455 return eptr->ext_alloc;
3456 }
3457
3458 #if defined (_MSC_VER) && COB_USE_VC2008_OR_GREATER
3459
3460 /* Get function pointer for most precise time function
3461 GetSystemTimePreciseAsFileTime is available since OS-version Windows 2000
3462 GetSystemTimeAsFileTime is available since OS-version Windows 8 / Server 2012
3463 */
3464 static void
get_function_ptr_for_precise_time(void)3465 get_function_ptr_for_precise_time (void)
3466 {
3467 HMODULE kernel32_handle;
3468
3469 kernel32_handle = GetModuleHandle (TEXT ("kernel32.dll"));
3470 if (kernel32_handle != NULL) {
3471 time_as_filetime_func = (VOID (WINAPI *) (LPFILETIME))
3472 GetProcAddress (kernel32_handle, "GetSystemTimePreciseAsFileTime");
3473 }
3474 if (time_as_filetime_func == NULL) {
3475 time_as_filetime_func = GetSystemTimeAsFileTime;
3476 }
3477 }
3478 #endif
3479
3480 /* split the timep to cob_time and set the offset from UTC */
3481 void
set_cob_time_from_localtime(time_t curtime,struct cob_time * cb_time)3482 static set_cob_time_from_localtime (time_t curtime, struct cob_time *cb_time) {
3483
3484 struct tm *tmptr;
3485 #if !defined (_BSD_SOURCE) && !defined (HAVE_TIMEZONE)
3486 time_t utctime, lcltime, difftime;
3487 #endif
3488
3489 tmptr = localtime (&curtime);
3490
3491 cb_time->year = tmptr->tm_year + 1900;
3492 cb_time->month = tmptr->tm_mon + 1;
3493 cb_time->day_of_month = tmptr->tm_mday;
3494 cb_time->day_of_week = one_indexed_day_of_week_from_monday (tmptr->tm_wday);
3495 cb_time->day_of_year = tmptr->tm_yday + 1;
3496 cb_time->hour = tmptr->tm_hour;
3497 cb_time->minute = tmptr->tm_min;
3498 /* LCOV_EXCL_START */
3499 /* Leap seconds ? */
3500 if (tmptr->tm_sec >= 60) {
3501 tmptr->tm_sec = 59;
3502 }
3503 /* LCOV_EXCL_STOP */
3504 cb_time->second = tmptr->tm_sec;
3505 cb_time->nanosecond = 0;
3506 cb_time->is_daylight_saving_time = tmptr->tm_isdst;
3507
3508 #if defined (_BSD_SOURCE)
3509 cb_time->offset_known = 1;
3510 cb_time->utc_offset = tmptr->tm_gmtoff / 60;
3511 #elif defined (HAVE_TIMEZONE)
3512 cb_time->offset_known = 1;
3513 cb_time->utc_offset = timezone / -60;
3514 /* LCOV_EXCL_START */
3515 if (tmptr->tm_isdst) {
3516 cb_time->utc_offset += 60;
3517 }
3518 /* LCOV_EXCL_STOP */
3519 #else
3520 lcltime = mktime (tmptr);
3521
3522 tmptr = gmtime (&curtime);
3523 utctime = mktime (tmptr);
3524
3525 if (utctime != -1 && lcltime != -1) { /* LCOV_EXCL_BR_LINE */
3526 difftime = utctime - lcltime;
3527 /* LCOV_EXCL_START */
3528 if (tmptr->tm_isdst) {
3529 difftime -= 3600;
3530 }
3531 /* LCOV_EXCL_STOP */
3532 cb_time->utc_offset = difftime / 60;
3533 cb_time->offset_known = 1;
3534 /* LCOV_EXCL_START */
3535 } else {
3536 cb_time->offset_known = 0;
3537 cb_time->utc_offset = 0;
3538 }
3539 /* LCOV_EXCL_STOP */
3540 #endif
3541 }
3542
3543 #if defined (_WIN32) /* cygwin does not define _WIN32 */
3544 static struct cob_time
cob_get_current_date_and_time_from_os(void)3545 cob_get_current_date_and_time_from_os (void)
3546 {
3547 SYSTEMTIME local_time;
3548 #if defined (_MSC_VER) && COB_USE_VC2008_OR_GREATER
3549 FILETIME filetime;
3550 SYSTEMTIME utc_time;
3551 #endif
3552
3553 time_t curtime;
3554 struct cob_time cb_time;
3555
3556 curtime = time (NULL);
3557 set_cob_time_from_localtime (curtime, &cb_time);
3558
3559 /* Get nanoseconds with highest precision possible */
3560 #if defined (_MSC_VER) && COB_USE_VC2008_OR_GREATER
3561 if (!time_as_filetime_func) {
3562 get_function_ptr_for_precise_time ();
3563 }
3564 #pragma warning(suppress: 6011) /* the function pointer is always set by get_function_ptr_for_precise_time */
3565 (time_as_filetime_func) (&filetime);
3566 /* fallback to GetLocalTime if one of the following does not work */
3567 if (FileTimeToSystemTime (&filetime, &utc_time) &&
3568 SystemTimeToTzSpecificLocalTime (NULL, &utc_time, &local_time)) {
3569 set_cob_time_ns_from_filetime (filetime, &cb_time);
3570 return cb_time;
3571 }
3572 #endif
3573 GetLocalTime (&local_time);
3574 cb_time.nanosecond = local_time.wMilliseconds * 1000000;
3575 return cb_time;
3576 }
3577 #else
3578 static struct cob_time
cob_get_current_date_and_time_from_os(void)3579 cob_get_current_date_and_time_from_os (void)
3580 {
3581 #if defined (HAVE_CLOCK_GETTIME)
3582 struct timespec time_spec;
3583 #elif defined (HAVE_SYS_TIME_H) && defined (HAVE_GETTIMEOFDAY)
3584 struct timeval tmv;
3585 #endif
3586 time_t curtime;
3587 struct cob_time cb_time;
3588
3589 /* Get the current time */
3590 #if defined (HAVE_CLOCK_GETTIME)
3591 clock_gettime (CLOCK_REALTIME, &time_spec);
3592 curtime = time_spec.tv_sec;
3593 #elif defined (HAVE_SYS_TIME_H) && defined (HAVE_GETTIMEOFDAY)
3594 gettimeofday (&tmv, NULL);
3595 curtime = tmv.tv_sec;
3596 #else
3597 curtime = time (NULL);
3598 #endif
3599
3600 set_cob_time_from_localtime (curtime, &cb_time);
3601
3602 /* Get nanoseconds or microseconds, if possible */
3603 #if defined (HAVE_CLOCK_GETTIME)
3604 cb_time.nanosecond = (int) time_spec.tv_nsec;
3605 #elif defined (HAVE_SYS_TIME_H) && defined (HAVE_GETTIMEOFDAY)
3606 cb_time.nanosecond = tmv.tv_usec * 1000;
3607 #else
3608 cb_time.nanosecond = 0;
3609 #endif
3610
3611 return cb_time;
3612 }
3613 #endif
3614
3615 struct cob_time
cob_get_current_date_and_time(void)3616 cob_get_current_date_and_time (void)
3617 {
3618 int needs_calculation = 0;
3619 time_t t;
3620 struct tm *tmptr;
3621 struct cob_time cb_time = cob_get_current_date_and_time_from_os ();
3622
3623 /* do we have a constant time? */
3624 if (cobsetptr != NULL
3625 && cobsetptr->cob_time_constant.year != 0) {
3626 if (cobsetptr->cob_time_constant.hour != -1) {
3627 cb_time.hour = cobsetptr->cob_time_constant.hour;
3628 }
3629 if (cobsetptr->cob_time_constant.minute != -1) {
3630 cb_time.minute = cobsetptr->cob_time_constant.minute;
3631 }
3632 if (cobsetptr->cob_time_constant.second != -1) {
3633 cb_time.second = cobsetptr->cob_time_constant.second;
3634 }
3635 if (cobsetptr->cob_time_constant.nanosecond != -1) {
3636 cb_time.nanosecond = cobsetptr->cob_time_constant.nanosecond;
3637 }
3638 if (cobsetptr->cob_time_constant.year != -1) {
3639 cb_time.year = cobsetptr->cob_time_constant.year;
3640 needs_calculation = 1;
3641 }
3642 if (cobsetptr->cob_time_constant.month != -1) {
3643 cb_time.month = cobsetptr->cob_time_constant.month;
3644 needs_calculation = 1;
3645 }
3646 if (cobsetptr->cob_time_constant.day_of_month != -1) {
3647 cb_time.day_of_month = cobsetptr->cob_time_constant.day_of_month;
3648 needs_calculation = 1;
3649 }
3650 if (cobsetptr->cob_time_constant.offset_known) {
3651 cb_time.offset_known = cobsetptr->cob_time_constant.offset_known;
3652 cb_time.utc_offset = cobsetptr->cob_time_constant.utc_offset;
3653 }
3654 }
3655
3656 /* Leap seconds ? */
3657 if (cb_time.second >= 60) {
3658 cb_time.second = 59;
3659 }
3660
3661 /* set day_of_week, day_of_year, is_daylight_saving_time, if necessary */
3662 if (needs_calculation) {
3663 /* allocate tmptr (needs a correct time) */
3664 time (&t);
3665 tmptr = localtime (&t);
3666 tmptr->tm_isdst = -1;
3667 tmptr->tm_sec = cb_time.second;
3668 tmptr->tm_min = cb_time.minute;
3669 tmptr->tm_hour = cb_time.hour;
3670 tmptr->tm_year = cb_time.year - 1900;
3671 tmptr->tm_mon = cb_time.month - 1;
3672 tmptr->tm_mday = cb_time.day_of_month;
3673 tmptr->tm_wday = -1;
3674 tmptr->tm_yday = -1;
3675 (void)mktime(tmptr);
3676 cb_time.day_of_week = one_indexed_day_of_week_from_monday (tmptr->tm_wday);
3677 cb_time.day_of_year = tmptr->tm_yday + 1;
3678 cb_time.is_daylight_saving_time = tmptr->tm_isdst;
3679 }
3680
3681 return cb_time;
3682 }
3683
3684 static void
check_current_date()3685 check_current_date ()
3686 {
3687 int yr, mm, dd, hh, mi, ss, ns;
3688 int offset = 9999;
3689 int i, j, ret;
3690 time_t t;
3691 struct tm *tmptr;
3692 char iso_timezone[7] = { '\0' };
3693 char nanoseconds[10];
3694
3695 if (cobsetptr == NULL
3696 || cobsetptr->cob_date == NULL) {
3697 return;
3698 }
3699
3700 j = ret = 0;
3701 yr = mm = dd = hh = mi = ss = ns = -1;
3702
3703 /* skip non-digits like quotes */
3704 while (cobsetptr->cob_date[j] != 0
3705 && cobsetptr->cob_date[j] != 'Y'
3706 && !isdigit((unsigned char)cobsetptr->cob_date[j])) {
3707 j++;
3708 }
3709
3710 /* extract date */
3711 if (cobsetptr->cob_date[j] != 0) {
3712 yr = 0;
3713 for (i = 0; cobsetptr->cob_date[j] != 0; j++) {
3714 if (isdigit ((unsigned char)cobsetptr->cob_date[j])) {
3715 yr = yr * 10 + COB_D2I (cobsetptr->cob_date[j]);
3716 } else {
3717 break;
3718 }
3719 if (++i == 4) {
3720 j++;
3721 break;
3722 }
3723 }
3724 if (i != 2 && i != 4) {
3725 if (cobsetptr->cob_date[j] == 'Y') {
3726 while (cobsetptr->cob_date[j] == 'Y') j++;
3727 } else {
3728 ret = 1;
3729 }
3730 yr = -1;
3731 } else if (yr < 100) {
3732 yr += 2000;
3733 }
3734 while (cobsetptr->cob_date[j] == '/'
3735 || cobsetptr->cob_date[j] == '-') {
3736 j++;
3737 }
3738 }
3739 if (cobsetptr->cob_date[j] != 0) {
3740 mm = 0;
3741 for (i = 0; cobsetptr->cob_date[j] != 0; j++) {
3742 if (isdigit ((unsigned char)cobsetptr->cob_date[j])) {
3743 mm = mm * 10 + COB_D2I (cobsetptr->cob_date[j]);
3744 } else {
3745 break;
3746 }
3747 if (++i == 2) {
3748 j++;
3749 break;
3750 }
3751 }
3752 if (i != 2) {
3753 if (cobsetptr->cob_date[j] == 'M') {
3754 while (cobsetptr->cob_date[j] == 'M') j++;
3755 } else {
3756 ret = 1;
3757 }
3758 mm = -1;
3759 } else if (mm < 1 || mm > 12) {
3760 ret = 1;
3761 }
3762 while (cobsetptr->cob_date[j] == '/'
3763 || cobsetptr->cob_date[j] == '-') {
3764 j++;
3765 }
3766 }
3767 if (cobsetptr->cob_date[j] != 0) {
3768 dd = 0;
3769 for (i = 0; cobsetptr->cob_date[j] != 0; j++) {
3770 if (isdigit ((unsigned char)cobsetptr->cob_date[j])) {
3771 dd = dd * 10 + COB_D2I (cobsetptr->cob_date[j]);
3772 } else {
3773 break;
3774 }
3775 if (++i == 2) {
3776 j++;
3777 break;
3778 }
3779 }
3780 if (i != 2) {
3781 if (cobsetptr->cob_date[j] == 'D') {
3782 while (cobsetptr->cob_date[j] == 'D') j++;
3783 } else {
3784 ret = 1;
3785 }
3786 dd = -1;
3787 } else if (dd < 1 || dd > 31) {
3788 ret = 1;
3789 }
3790 }
3791
3792 /* extract time */
3793 if (cobsetptr->cob_date[j] != 0) {
3794 hh = 0;
3795 while (isspace ((unsigned char)cobsetptr->cob_date[j])) j++;
3796 for (i = 0; cobsetptr->cob_date[j] != 0; j++) {
3797 if (isdigit ((unsigned char)cobsetptr->cob_date[j])) {
3798 hh = hh * 10 + COB_D2I (cobsetptr->cob_date[j]);
3799 } else {
3800 break;
3801 }
3802 if (++i == 2) {
3803 j++;
3804 break;
3805 }
3806 }
3807
3808 if (i != 2) {
3809 if (cobsetptr->cob_date[j] == 'H') {
3810 while (cobsetptr->cob_date[j] == 'H') j++;
3811 } else {
3812 ret = 1;
3813 }
3814 hh = -1;
3815 } else if (hh > 23) {
3816 ret = 1;
3817 }
3818 while (cobsetptr->cob_date[j] == ':'
3819 || cobsetptr->cob_date[j] == '-')
3820 j++;
3821 }
3822 if (cobsetptr->cob_date[j] != 0) {
3823 mi = 0;
3824 for (i = 0; cobsetptr->cob_date[j] != 0; j++) {
3825 if (isdigit ((unsigned char)cobsetptr->cob_date[j])) {
3826 mi = mi * 10 + COB_D2I (cobsetptr->cob_date[j]);
3827 } else {
3828 break;
3829 }
3830 if (++i == 2) {
3831 j++;
3832 break;
3833 }
3834 }
3835 if (i != 2) {
3836 if (cobsetptr->cob_date[j] == 'M') {
3837 while (cobsetptr->cob_date[j] == 'M') j++;
3838 } else {
3839 ret = 1;
3840 }
3841 mi = -1;
3842 } else if (mi > 59) {
3843 ret = 1;
3844 }
3845 while (cobsetptr->cob_date[j] == ':'
3846 || cobsetptr->cob_date[j] == '-') {
3847 j++;
3848 }
3849 }
3850
3851 if (cobsetptr->cob_date[j] != 0
3852 && cobsetptr->cob_date[j] != 'Z'
3853 && cobsetptr->cob_date[j] != '+'
3854 && cobsetptr->cob_date[j] != '-') {
3855 ss = 0;
3856 for (i = 0; cobsetptr->cob_date[j] != 0; j++) {
3857 if (isdigit ((unsigned char)cobsetptr->cob_date[j])) {
3858 ss = ss * 10 + COB_D2I (cobsetptr->cob_date[j]);
3859 } else {
3860 break;
3861 }
3862 if (++i == 2) {
3863 j++;
3864 break;
3865 }
3866 }
3867 if (i != 2) {
3868 if (cobsetptr->cob_date[j] == 'S') {
3869 while (cobsetptr->cob_date[j] == 'S') j++;
3870 } else {
3871 ret = 1;
3872 }
3873 ss = -1;
3874 /* leap second would be 60 */
3875 } else if (ss > 60) {
3876 ret = 1;
3877 }
3878 }
3879
3880 if (cobsetptr->cob_date[j] != 0
3881 && cobsetptr->cob_date[j] != 'Z'
3882 && cobsetptr->cob_date[j] != '+'
3883 && cobsetptr->cob_date[j] != '-') {
3884 ns = 0;
3885 if (cobsetptr->cob_date[j] == '.'
3886 || cobsetptr->cob_date[j] == ':') {
3887 j++;
3888 }
3889 strcpy (nanoseconds, "000000000");
3890 for (i=0; cobsetptr->cob_date[j] != 0; j++) {
3891 if (isdigit ((unsigned char)cobsetptr->cob_date[j])) {
3892 nanoseconds[i] = cobsetptr->cob_date[j];
3893 } else {
3894 break;
3895 }
3896 if (++i == 9) {
3897 j++;
3898 break;
3899 }
3900 }
3901 ns = atoi(nanoseconds);
3902 }
3903
3904 /* extract UTC offset */
3905 if (cobsetptr->cob_date[j] == 'Z') {
3906 offset = 0;
3907 iso_timezone[0] = 'Z';
3908 } else if (cobsetptr->cob_date[j] == '+'
3909 || cobsetptr->cob_date[j] == '-') {
3910 char *iso_timezone_ptr = (char *)&iso_timezone;
3911 strncpy (iso_timezone_ptr, cobsetptr->cob_date + j, 6);
3912 iso_timezone[6] = 0; /* just to keep the analyzer happy */
3913 if (strlen (iso_timezone_ptr) == 3) {
3914 strcpy (iso_timezone_ptr + 3, "00");
3915 } else if (iso_timezone[3] == ':') {
3916 strncpy (iso_timezone_ptr + 3, cobsetptr->cob_date + j + 4, 3);
3917 }
3918 for (i=1; iso_timezone[i] != 0; i++) {
3919 if (!isdigit ((unsigned char)iso_timezone[i])) {
3920 break;
3921 }
3922 if (++i == 4) {
3923 break;
3924 }
3925 }
3926 if (i == 4) {
3927 offset = COB_D2I (iso_timezone[1]) * 60 * 10
3928 + COB_D2I (iso_timezone[2]) * 60
3929 + COB_D2I (iso_timezone[3]) * 10
3930 + COB_D2I (iso_timezone[4]);
3931 if (iso_timezone[0] == '-') {
3932 offset *= -1;
3933 }
3934 } else {
3935 ret = 1;
3936 iso_timezone[0] = '\0';
3937 }
3938 }
3939
3940 if (ret != 0) {
3941 cob_runtime_warning (_("COB_CURRENT_DATE '%s' is invalid"), cobsetptr->cob_date);
3942 }
3943
3944 /* get local time, allocate tmptr */
3945 time(&t);
3946 tmptr = localtime (&t);
3947
3948 /* override given parts in time */
3949 if (ss != -1) {
3950 tmptr->tm_sec = ss;
3951 }
3952 if (mi != -1) {
3953 tmptr->tm_min = mi;
3954 }
3955 if (hh != -1) {
3956 tmptr->tm_hour = hh;
3957 }
3958 if (yr != -1) {
3959 tmptr->tm_year = yr - 1900;
3960 }
3961 if (mm != -1) {
3962 tmptr->tm_mon = mm - 1;
3963 }
3964 if (dd != -1) {
3965 tmptr->tm_mday = dd;
3966 }
3967 tmptr->tm_isdst = -1;
3968
3969 /* normalize if needed (for example 40 October is changed into 9 November),
3970 set tm_wday, tm_yday and tm_isdst */
3971 t = mktime (tmptr);
3972
3973 /* set datetime constant */
3974
3975 if (hh != -1) {
3976 cobsetptr->cob_time_constant.hour = tmptr->tm_hour;
3977 } else {
3978 cobsetptr->cob_time_constant.hour = -1;
3979 }
3980 if (mi != -1) {
3981 cobsetptr->cob_time_constant.minute = tmptr->tm_min;
3982 } else {
3983 cobsetptr->cob_time_constant.minute = -1;
3984 }
3985 if (ss != -1) {
3986 cobsetptr->cob_time_constant.second = tmptr->tm_sec;
3987 } else {
3988 cobsetptr->cob_time_constant.second = -1;
3989 }
3990 if (ns != -1) {
3991 cobsetptr->cob_time_constant.nanosecond = ns;
3992 } else {
3993 cobsetptr->cob_time_constant.nanosecond = -1;
3994 }
3995 if (yr != -1) {
3996 cobsetptr->cob_time_constant.year = tmptr->tm_year + 1900;
3997 } else {
3998 cobsetptr->cob_time_constant.year = -1;
3999 }
4000 if (mm != -1) {
4001 cobsetptr->cob_time_constant.month = tmptr->tm_mon + 1;
4002 } else {
4003 cobsetptr->cob_time_constant.month = -1;
4004 }
4005 if (dd != -1) {
4006 cobsetptr->cob_time_constant.day_of_month = tmptr->tm_mday;
4007 } else {
4008 cobsetptr->cob_time_constant.day_of_month = -1;
4009 }
4010
4011 /* the following are only set in "current" instances, not in the constant */
4012 cobsetptr->cob_time_constant.day_of_week = -1;
4013 cobsetptr->cob_time_constant.day_of_year = -1;
4014 cobsetptr->cob_time_constant.is_daylight_saving_time = -1;
4015
4016 if (iso_timezone[0] != '\0') {
4017 cobsetptr->cob_time_constant.offset_known = 1;
4018 cobsetptr->cob_time_constant.utc_offset = offset;
4019 } else {
4020 cobsetptr->cob_time_constant.offset_known = 0;
4021 cobsetptr->cob_time_constant.utc_offset = 0;
4022 }
4023 }
4024
4025 /* Extended ACCEPT/DISPLAY */
4026
4027 void
cob_accept_date(cob_field * field)4028 cob_accept_date (cob_field *field)
4029 {
4030 struct cob_time time;
4031 char buff[16]; /* 16: make the compiler happy as "unsigned short" *could*
4032 have more digits than we "assume" */
4033
4034 time = cob_get_current_date_and_time ();
4035
4036 snprintf(buff, sizeof (buff), "%2.2d%2.2d%2.2d",
4037 (cob_u16_t) time.year % 100,
4038 (cob_u16_t) time.month,
4039 (cob_u16_t) time.day_of_month);
4040 cob_memcpy (field, buff, (size_t)6);
4041 }
4042
4043 void
cob_accept_date_yyyymmdd(cob_field * field)4044 cob_accept_date_yyyymmdd (cob_field *field)
4045 {
4046 struct cob_time time;
4047 char buff[16]; /* 16: make the compiler happy as "unsigned short" *could*
4048 have more digits than we "assume" */
4049
4050 time = cob_get_current_date_and_time ();
4051
4052 snprintf (buff, sizeof (buff), "%4.4d%2.2d%2.2d",
4053 (cob_u16_t) time.year,
4054 (cob_u16_t) time.month,
4055 (cob_u16_t) time.day_of_month);
4056 cob_memcpy (field, buff, (size_t)8);
4057 }
4058
4059 void
cob_accept_day(cob_field * field)4060 cob_accept_day (cob_field *field)
4061 {
4062 struct cob_time time;
4063 char buff[11]; /* 11: make the compiler happy as "unsigned short" *could*
4064 have more digits than we "assume" */
4065
4066 time = cob_get_current_date_and_time ();
4067 snprintf (buff, sizeof (buff), "%2.2d%3.3d",
4068 (cob_u16_t) time.year % 100,
4069 (cob_u16_t) time.day_of_year);
4070 cob_memcpy (field, buff, (size_t)5);
4071 }
4072
4073 void
cob_accept_day_yyyyddd(cob_field * field)4074 cob_accept_day_yyyyddd (cob_field *field)
4075 {
4076 struct cob_time time;
4077 char buff[11]; /* 11: make the compiler happy as "unsigned short" *could*
4078 have more digits than we "assume" */
4079
4080 time = cob_get_current_date_and_time ();
4081 snprintf (buff, sizeof (buff), "%4.4d%3.3d",
4082 (cob_u16_t) time.year,
4083 (cob_u16_t) time.day_of_year);
4084 cob_memcpy (field, buff, (size_t)7);
4085 }
4086
4087 void
cob_accept_day_of_week(cob_field * field)4088 cob_accept_day_of_week (cob_field *field)
4089 {
4090 struct cob_time time;
4091 unsigned char day;
4092
4093 time = cob_get_current_date_and_time ();
4094 day = (unsigned char)(time.day_of_week + '0');
4095 cob_memcpy (field, &day, (size_t)1);
4096 }
4097
4098 void
cob_accept_time(cob_field * field)4099 cob_accept_time (cob_field *field)
4100 {
4101 struct cob_time time;
4102 char buff[21]; /* 11: make the compiler happy as "unsigned short" *could*
4103 have more digits than we "assume" */
4104
4105 time = cob_get_current_date_and_time ();
4106 snprintf (buff, sizeof (buff), "%2.2d%2.2d%2.2d%2.2d",
4107 (cob_u16_t) time.hour,
4108 (cob_u16_t) time.minute,
4109 (cob_u16_t) time.second,
4110 (cob_u16_t) (time.nanosecond / 10000000));
4111
4112 cob_memcpy (field, buff, (size_t)8);
4113 }
4114
4115 void
cob_display_command_line(cob_field * f)4116 cob_display_command_line (cob_field *f)
4117 {
4118 if (commlnptr) {
4119 cob_free (commlnptr);
4120 }
4121 commlnptr = cob_malloc (f->size + 1U);
4122 commlncnt = f->size;
4123 memcpy (commlnptr, f->data, commlncnt);
4124 }
4125
4126 void
cob_accept_command_line(cob_field * f)4127 cob_accept_command_line (cob_field *f)
4128 {
4129 char *buff;
4130 size_t i;
4131 size_t size;
4132 size_t len;
4133
4134 if (commlncnt) {
4135 cob_memcpy (f, commlnptr, commlncnt);
4136 return;
4137 }
4138
4139 if (cob_argc <= 1) {
4140 cob_memcpy (f, " ", (size_t)1);
4141 return;
4142 }
4143
4144 size = 0;
4145 for (i = 1; i < (size_t)cob_argc; ++i) {
4146 size += (strlen (cob_argv[i]) + 1);
4147 if (size > f->size) {
4148 break;
4149 }
4150 }
4151 buff = cob_malloc (size);
4152 buff[0] = ' ';
4153 size = 0;
4154 for (i = 1; i < (size_t)cob_argc; ++i) {
4155 len = strlen (cob_argv[i]);
4156 memcpy (buff + size, cob_argv[i], len);
4157 size += len;
4158 if (i != (size_t)cob_argc - 1U) {
4159 buff[size++] = ' ';
4160 }
4161 if (size > f->size) {
4162 break;
4163 }
4164 }
4165 cob_memcpy (f, buff, size);
4166 cob_free (buff);
4167 }
4168
4169 /* Argument number */
4170
4171 void
cob_display_arg_number(cob_field * f)4172 cob_display_arg_number (cob_field *f)
4173 {
4174 int n;
4175 cob_field_attr attr;
4176 cob_field temp;
4177
4178 temp.size = 4;
4179 temp.data = (unsigned char *)&n;
4180 temp.attr = &attr;
4181 COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, 9, 0, 0, NULL);
4182 cob_move (f, &temp);
4183 if (n < 0 || n >= cob_argc) {
4184 cob_set_exception (COB_EC_IMP_DISPLAY);
4185 return;
4186 }
4187 current_arg = n;
4188 }
4189
4190 void
cob_accept_arg_number(cob_field * f)4191 cob_accept_arg_number (cob_field *f)
4192 {
4193 int n;
4194 cob_field_attr attr;
4195 cob_field temp;
4196
4197 n = cob_argc - 1;
4198 temp.size = 4;
4199 temp.data = (unsigned char *)&n;
4200 temp.attr = &attr;
4201 COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, 9, 0, 0, NULL);
4202 cob_move (&temp, f);
4203 }
4204
4205 void
cob_accept_arg_value(cob_field * f)4206 cob_accept_arg_value (cob_field *f)
4207 {
4208 if (current_arg >= cob_argc) {
4209 cob_set_exception (COB_EC_IMP_ACCEPT);
4210 return;
4211 }
4212 cob_memcpy (f, cob_argv[current_arg],
4213 strlen (cob_argv[current_arg]));
4214 current_arg++;
4215 }
4216
4217 /* Environment variable handling */
4218
4219 #ifdef _MSC_VER
4220 /* _MSC does *NOT* have `setenv` (!)
4221 But as the handling of the fallback `putenv` is different in POSIX and _MSC
4222 (POSIX stores no duplicate of `putenv`, where _MSC does), we pretend to
4223 have support for `setenv` and define it here with the same behaviour: */
4224
4225 static COB_INLINE COB_A_INLINE int
setenv(const char * name,const char * value,int overwrite)4226 setenv (const char *name, const char *value, int overwrite) {
4227 /* remark: _putenv_s does always overwrite, add a check for overwrite = 1 if necessary later */
4228 COB_UNUSED (overwrite);
4229 return _putenv_s (name,value);
4230 }
4231 static COB_INLINE COB_A_INLINE int
unsetenv(const char * name)4232 unsetenv (const char *name) {
4233 return _putenv_s (name,"");
4234 }
4235 #endif
4236
4237 /* set entry into environment, with/without overwriting existing values */
4238 int
cob_setenv(const char * name,const char * value,int overwrite)4239 cob_setenv (const char *name, const char *value, int overwrite) {
4240 #if defined (HAVE_SETENV) && HAVE_SETENV
4241 return setenv (name, value, overwrite);
4242 #else
4243 char *env;
4244 size_t len;
4245
4246 COB_UNUSED (overwrite);
4247 len = strlen (name) + strlen (value) + 2U;
4248 env = cob_fast_malloc (len);
4249 sprintf (env, "%s=%s", name, value);
4250 return putenv (env);
4251 #endif
4252 }
4253
4254 /* remove entry from environment */
4255 int
cob_unsetenv(const char * name)4256 cob_unsetenv (const char *name) {
4257 #if defined(HAVE_SETENV) && HAVE_SETENV
4258 return unsetenv (name);
4259 #else
4260 char *env;
4261
4262 env = cob_fast_malloc (strlen (name) + 2U);
4263 sprintf (env, "%s=", name);
4264 return putenv (env);
4265 #endif
4266 }
4267
4268 /* resolve entry from environment */
4269 char *
cob_getenv_direct(const char * name)4270 cob_getenv_direct (const char *name) {
4271 return getenv (name);
4272 }
4273
4274 /* resolve entry from environment and return an allocated string copy
4275 --> call cob_free after use! */
4276 char *
cob_getenv(const char * name)4277 cob_getenv (const char *name)
4278 {
4279 char *p;
4280
4281 if (name) {
4282 p = getenv (name);
4283 if (p) {
4284 return cob_strdup (p);
4285 }
4286 }
4287 return NULL;
4288 }
4289
4290 int
cob_putenv(char * name)4291 cob_putenv (char *name)
4292 {
4293 int ret;
4294
4295 if (name && strchr (name, '=')) {
4296 ret = putenv (cob_strdup (name));
4297 if (!ret) {
4298 cob_rescan_env_vals ();
4299 }
4300 return ret;
4301 }
4302 return -1;
4303 }
4304
4305 void
cob_display_environment(const cob_field * f)4306 cob_display_environment (const cob_field *f)
4307 {
4308 size_t i;
4309
4310 if (cob_local_env_size < f->size) {
4311 cob_local_env_size = f->size;
4312 if (cob_local_env) {
4313 cob_free (cob_local_env);
4314 }
4315 cob_local_env = cob_malloc (cob_local_env_size + 1U);
4316 }
4317 cob_field_to_string (f, cob_local_env, cob_local_env_size);
4318 if (unlikely (cobsetptr->cob_env_mangle)) {
4319 for (i = 0; i < strlen (cob_local_env); ++i) {
4320 if (!isalnum ((int)cob_local_env[i])) {
4321 cob_local_env[i] = '_';
4322 }
4323 }
4324 }
4325 }
4326
4327 void
cob_display_env_value(const cob_field * f)4328 cob_display_env_value (const cob_field *f)
4329 {
4330 char *env2;
4331 int ret;
4332
4333 if (!cob_local_env) {
4334 cob_set_exception (COB_EC_IMP_DISPLAY);
4335 return;
4336 }
4337 if (!*cob_local_env) {
4338 cob_set_exception (COB_EC_IMP_DISPLAY);
4339 return;
4340 }
4341 env2 = cob_malloc (f->size + 1U);
4342 cob_field_to_string (f, env2, f->size);
4343 ret = cob_setenv (cob_local_env, env2, 1);
4344 cob_free (env2);
4345 if (ret != 0) {
4346 cob_set_exception (COB_EC_IMP_DISPLAY);
4347 return;
4348 }
4349 /* Rescan term/screen variables */
4350 cob_rescan_env_vals ();
4351 }
4352
4353 void
cob_set_environment(const cob_field * f1,const cob_field * f2)4354 cob_set_environment (const cob_field *f1, const cob_field *f2)
4355 {
4356 cob_display_environment (f1);
4357 cob_display_env_value (f2);
4358 }
4359
4360 void
cob_get_environment(const cob_field * envname,cob_field * envval)4361 cob_get_environment (const cob_field *envname, cob_field *envval)
4362 {
4363 const char *p;
4364 char *buff;
4365 size_t size;
4366
4367 if (envname->size == 0 || envval->size == 0) {
4368 cob_set_exception (COB_EC_IMP_ACCEPT);
4369 return;
4370 }
4371
4372 buff = cob_malloc (envname->size + 1U);
4373 cob_field_to_string (envname, buff, envname->size);
4374 if (unlikely (cobsetptr->cob_env_mangle)) {
4375 for (size = 0; size < strlen (buff); ++size) {
4376 if (!isalnum ((int)buff[size])) {
4377 buff[size] = '_';
4378 }
4379 }
4380 }
4381 p = getenv (buff);
4382 if (!p) {
4383 cob_set_exception (COB_EC_IMP_ACCEPT);
4384 p = " ";
4385 }
4386 cob_memcpy (envval, p, strlen (p));
4387 cob_free (buff);
4388 }
4389
4390 void
cob_accept_environment(cob_field * f)4391 cob_accept_environment (cob_field *f)
4392 {
4393 const char *p = NULL;
4394
4395 if (cob_local_env) {
4396 p = getenv (cob_local_env);
4397 }
4398 if (!p) {
4399 cob_set_exception (COB_EC_IMP_ACCEPT);
4400 p = " ";
4401 }
4402 cob_memcpy (f, p, strlen (p));
4403 }
4404
4405 void
cob_chain_setup(void * data,const size_t parm,const size_t size)4406 cob_chain_setup (void *data, const size_t parm, const size_t size)
4407 {
4408 size_t len;
4409
4410 /* only set if given on command-line, otherwise use normal
4411 program internal initialization */
4412 if (parm <= (size_t)cob_argc - 1) {
4413 memset (data, ' ', size);
4414 len = strlen (cob_argv[parm]);
4415 if (len <= size) {
4416 memcpy (data, cob_argv[parm], len);
4417 } else {
4418 memcpy (data, cob_argv[parm], size);
4419 }
4420 }
4421 }
4422
4423 void
cob_continue_after(cob_field * decimal_seconds)4424 cob_continue_after (cob_field *decimal_seconds)
4425 {
4426 cob_s64_t nanoseconds = get_sleep_nanoseconds_from_seconds (decimal_seconds);
4427
4428 if (nanoseconds < 0) {
4429 /* TODO: current COBOL 20xx change proposal
4430 specifies EC-CONTINUE-LESS-THAN-ZERO (NF) here... */
4431 return;
4432 }
4433 internal_nanosleep (nanoseconds);
4434 }
4435
4436 void
cob_allocate(unsigned char ** dataptr,cob_field * retptr,cob_field * sizefld,cob_field * initialize)4437 cob_allocate (unsigned char **dataptr, cob_field *retptr,
4438 cob_field *sizefld, cob_field *initialize)
4439 {
4440 void *mptr;
4441 struct cob_alloc_cache *cache_ptr;
4442 int fsize;
4443 cob_field temp;
4444
4445 /* ALLOCATE */
4446 cobglobptr->cob_exception_code = 0;
4447 mptr = NULL;
4448 fsize = cob_get_int (sizefld);
4449 /* FIXME: doesn't work correctly if fsize is > INT_MAX */
4450 if (fsize > COB_MAX_ALLOC_SIZE) {
4451 cob_set_exception (COB_EC_STORAGE_IMP);
4452 } else if (fsize > 0) {
4453 cache_ptr = cob_malloc (sizeof (struct cob_alloc_cache));
4454 mptr = malloc ((size_t)fsize);
4455 if (!mptr) {
4456 cob_set_exception (COB_EC_STORAGE_NOT_AVAIL);
4457 cob_free (cache_ptr);
4458 } else {
4459 if (initialize) {
4460 temp.size = (size_t)fsize;
4461 temp.data = mptr;
4462 temp.attr = &const_alpha_attr;
4463 cob_move (initialize, &temp);
4464 } else {
4465 memset (mptr, 0, (size_t)fsize);
4466 }
4467 cache_ptr->cob_pointer = mptr;
4468 cache_ptr->size = (size_t)fsize;
4469 cache_ptr->next = cob_alloc_base;
4470 cob_alloc_base = cache_ptr;
4471 }
4472 }
4473 if (dataptr) {
4474 *dataptr = mptr;
4475 }
4476 if (retptr) {
4477 *(void **)(retptr->data) = mptr;
4478 }
4479 }
4480
4481 void
cob_free_alloc(unsigned char ** ptr1,unsigned char * ptr2)4482 cob_free_alloc (unsigned char **ptr1, unsigned char *ptr2)
4483 {
4484 struct cob_alloc_cache *cache_ptr;
4485 struct cob_alloc_cache *prev_ptr;
4486
4487 /* FREE */
4488 cobglobptr->cob_exception_code = 0;
4489 cache_ptr = cob_alloc_base;
4490 prev_ptr = cob_alloc_base;
4491 if (ptr1 && *ptr1) {
4492 void *vptr1;
4493 vptr1 = *ptr1;
4494 for (; cache_ptr; cache_ptr = cache_ptr->next) {
4495 if (vptr1 == cache_ptr->cob_pointer) {
4496 cob_free (cache_ptr->cob_pointer);
4497 if (cache_ptr == cob_alloc_base) {
4498 cob_alloc_base = cache_ptr->next;
4499 } else {
4500 prev_ptr->next = cache_ptr->next;
4501 }
4502 cob_free (cache_ptr);
4503 *ptr1 = NULL;
4504 return;
4505 }
4506 prev_ptr = cache_ptr;
4507 }
4508 cob_set_exception (COB_EC_STORAGE_NOT_ALLOC);
4509 return;
4510 }
4511 if (ptr2 && *(void **)ptr2) {
4512 for (; cache_ptr; cache_ptr = cache_ptr->next) {
4513 if (*(void **)ptr2 == cache_ptr->cob_pointer) {
4514 cob_free (cache_ptr->cob_pointer);
4515 if (cache_ptr == cob_alloc_base) {
4516 cob_alloc_base = cache_ptr->next;
4517 } else {
4518 prev_ptr->next = cache_ptr->next;
4519 }
4520 cob_free (cache_ptr);
4521 *(void **)ptr2 = NULL;
4522 return;
4523 }
4524 prev_ptr = cache_ptr;
4525 }
4526 cob_set_exception (COB_EC_STORAGE_NOT_ALLOC);
4527 return;
4528 }
4529 }
4530
4531 #if 0 /* debug only */
4532 void print_stat (const char *filename, struct stat sb)
4533 {
4534 printf("File name: ");
4535 if (filename) {
4536 printf ("%s\n", filename);
4537 } else {
4538 printf("- unknown -\n");
4539 }
4540 printf("File type: ");
4541
4542 switch (sb.st_mode & S_IFMT) {
4543 #ifdef S_IFBLK
4544 case S_IFBLK: printf("block device\n"); break;
4545 #endif
4546 #ifdef S_IFCHR
4547 case S_IFCHR: printf("character device\n"); break;
4548 #endif
4549 case S_IFDIR: printf("directory\n"); break;
4550 #ifdef S_IFIFO
4551 case S_IFIFO: printf("FIFO/pipe\n"); break;
4552 #endif
4553 #ifdef S_IFLNK
4554 case S_IFLNK: printf("symlink\n"); break;
4555 #endif
4556 case S_IFREG: printf("regular file\n"); break;
4557 #ifdef S_IFSOCK
4558 case S_IFSOCK: printf("socket\n"); break;
4559 #endif
4560 default: printf("unknown?\n"); break;
4561 }
4562
4563 printf("I-node number: %ld\n", (long)sb.st_ino);
4564
4565 printf("Mode: %lo (octal)\n",
4566 (unsigned long)sb.st_mode);
4567
4568 printf("Link count: %ld\n", (long)sb.st_nlink);
4569 printf("Ownership: UID=%ld GID=%ld\n",
4570 (long)sb.st_uid, (long)sb.st_gid);
4571 printf("File size: %lld bytes\n",
4572 (long long)sb.st_size);
4573 #if 0
4574 printf("Preferred I/O block size: %ld bytes\n",
4575 (long)sb.st_blksize);
4576 printf("Blocks allocated: %lld\n",
4577 (long long)sb.st_blocks);
4578 #endif
4579
4580 printf("Last status change: %s", ctime(&sb.st_ctime));
4581 printf("Last file access: %s", ctime(&sb.st_atime));
4582 printf("Last file modification: %s", ctime(&sb.st_mtime));
4583 }
4584 #endif
4585
4586 static COB_INLINE int
check_valid_dir(const char * dir)4587 check_valid_dir (const char *dir)
4588 {
4589 struct stat sb;
4590 if (strlen (dir) > COB_NORMAL_MAX) return 1;
4591 if (stat (dir, &sb) || !(S_ISDIR (sb.st_mode))) return 1;
4592
4593 #if 0
4594 print_stat (dir, sb);
4595 #endif
4596
4597 return 0;
4598 }
4599
4600 static const char *
check_valid_env_tmpdir(const char * envname)4601 check_valid_env_tmpdir (const char * envname)
4602 {
4603 const char *dir;
4604
4605 dir = getenv (envname);
4606 if (!dir || !dir[0]) {
4607 return NULL;
4608 }
4609 if (check_valid_dir (dir)) {
4610 cob_runtime_warning ("Temporary directory %s is invalid, adjust TMPDIR!", envname);
4611 (void)cob_unsetenv (envname);
4612 return NULL;
4613 }
4614 return dir;
4615 }
4616
4617
4618 /* return pointer to TMPDIR without trailing slash */
4619 static const char *
cob_gettmpdir(void)4620 cob_gettmpdir (void)
4621 {
4622 const char *tmpdir;
4623 char *tmp;
4624
4625 if ((tmpdir = check_valid_env_tmpdir ("TMPDIR")) == NULL) {
4626 tmp = NULL;
4627 #ifdef _WIN32
4628 if ((tmpdir = check_valid_env_tmpdir ("TEMP")) == NULL
4629 && (tmpdir = check_valid_env_tmpdir ("TMP")) == NULL
4630 && (tmpdir = check_valid_env_tmpdir ("USERPROFILE")) == NULL) {
4631 #else
4632 if ((tmpdir = check_valid_env_tmpdir ("TMP")) == NULL
4633 && (tmpdir = check_valid_env_tmpdir ("TEMP")) == NULL) {
4634 if (!check_valid_dir ("/tmp")) {
4635 tmp = cob_fast_malloc (5U);
4636 strcpy (tmp, "/tmp");
4637 tmpdir = tmp;
4638 }
4639 }
4640 if (!tmpdir) {
4641 #endif
4642 tmp = cob_fast_malloc (2U);
4643 tmp[0] = '.';
4644 tmp[1] = 0;
4645 tmpdir = tmp;
4646 } else {
4647 size_t size = strlen (tmpdir) - 1;
4648 if (tmpdir[size] == SLASH_CHAR) {
4649 tmp = (char*)cob_fast_malloc (size);
4650 memcpy (tmp, tmpdir, size);
4651 tmp[size] = 0;
4652 tmpdir = tmp;
4653 }
4654 }
4655 (void)cob_setenv ("TMPDIR", tmpdir, 1);
4656 if (tmp) {
4657 cob_free ((void *)tmp);
4658 tmpdir = getenv ("TMPDIR");
4659 }
4660 }
4661 return tmpdir;
4662 }
4663
4664 /* Set temporary file name */
4665 void
4666 cob_temp_name (char *filename, const char *ext)
4667 {
4668 int pid = cob_sys_getpid ();
4669 #ifndef HAVE_8DOT3_FILENAMES
4670 #define TEMP_EXT_SCHEMA "%s%ccob%d_%d%s"
4671 #define TEMP_SORT_SCHEMA "%s%ccobsort%d_%d"
4672 #else
4673 /* 8.3 allows only short names... */
4674 #define TEMP_EXT_SCHEMA "%s%cc%d_%d%s"
4675 #define TEMP_SORT_SCHEMA "%s%cs%d_%d"
4676 pid = pid % 9999;
4677 #endif
4678 if (ext) {
4679 snprintf (filename, (size_t)COB_FILE_MAX, TEMP_EXT_SCHEMA,
4680 cob_gettmpdir (), SLASH_CHAR, pid, cob_temp_iteration, ext);
4681 } else {
4682 snprintf (filename, (size_t)COB_FILE_MAX, TEMP_SORT_SCHEMA,
4683 cob_gettmpdir (), SLASH_CHAR, pid, cob_temp_iteration);
4684 }
4685 #undef TEMP_EXT_SCHEMA
4686 #undef TEMP_SORT_SCHEMA
4687 }
4688
4689 void
4690 cob_incr_temp_iteration (void)
4691 {
4692 cob_temp_iteration++;
4693 }
4694
4695 int
4696 cob_extern_init (void)
4697 {
4698 /* can be called multiple times (MF docs say: should be done in all threads) */
4699 if (!cob_initialized) {
4700 cob_init (0, NULL);
4701 }
4702 return 0;
4703 }
4704
4705 char *
4706 cob_command_line (int flags, int *pargc, char ***pargv,
4707 char ***penvp, char **pname)
4708 {
4709 #if 0 /* RXWRXW cob_command_line */
4710 char **spenvp;
4711 char *spname;
4712 #else
4713 COB_UNUSED (penvp);
4714 COB_UNUSED (pname);
4715 #endif
4716
4717 COB_UNUSED (flags);
4718
4719 if (!cob_initialized) {
4720 cob_fatal_error (COB_FERROR_INITIALIZED);
4721 }
4722 if (pargc && pargv) {
4723 cob_argc = *pargc;
4724 cob_argv = *pargv;
4725 }
4726
4727 #if 0 /* RXWRXW cob_command_line */
4728 if (penvp) {
4729 spenvp = *penvp;
4730 }
4731 if (pname) {
4732 spname = *pname;
4733 }
4734 #endif
4735
4736 /* What are we supposed to return here? */
4737 return NULL;
4738 }
4739
4740 int
4741 cob_tidy (void)
4742 {
4743 struct exit_handlerlist *h;
4744
4745 if (!cob_initialized) {
4746 return 1;
4747 }
4748 if (exit_hdlrs != NULL) {
4749 h = exit_hdlrs;
4750 while (h != NULL) {
4751 h->proc ();
4752 h = h->next;
4753 }
4754 }
4755 cob_terminate_routines ();
4756 return 0;
4757 }
4758
4759 /* System routines */
4760
4761 int
4762 cob_sys_exit_proc (const void *dispo, const void *pptr)
4763 {
4764 struct exit_handlerlist *hp;
4765 struct exit_handlerlist *h;
4766 unsigned char data_buff;
4767 const unsigned char *install_flag;
4768 const unsigned char *priority;
4769 int (**p)(void);
4770
4771 COB_CHK_PARMS (CBL_EXIT_PROC, 2);
4772
4773 #if 0 /* TODO: take care of ACU variant:
4774 pptr is not an already resolved entry point
4775 but a name which is to be cob_resolve'd (at use-time);
4776 maybe resolve here and return -1 if not possible;
4777 furthermore the second parameter is a mixed priority + install_flag */
4778 if (something) {
4779 const char *name = (char *)pptr;
4780 pptr = cob_resolve_cobol (name, 0, 0);
4781
4782 if (!p) {
4783 return -1;
4784 }
4785
4786 install_flag = &data_buff;
4787 memcpy (&priority, &disp, sizeof (unsigned char *));
4788 if (priority == 254) {
4789 *install_flag = 1;
4790 } else if (priority == 255) {
4791 *install_flag = 2;
4792 } else {
4793 *install_flag = 3;
4794 }
4795
4796 } else {
4797 #endif
4798 memcpy (&p, &pptr, sizeof (void *));
4799
4800 if (!p || !*p) {
4801 return -1;
4802 }
4803
4804 install_flag = dispo;
4805 if (*install_flag > 3) {
4806 return -1;
4807 }
4808 if (*install_flag == 2 || *install_flag == 3) {
4809 memcpy ((void*)(&priority), &pptr + sizeof (void *), sizeof (unsigned char *));
4810 if (*install_flag == 3 && *priority > 127) {
4811 data_buff = 64;
4812 priority = &data_buff;
4813 }
4814 } else {
4815 data_buff = 64;
4816 priority = &data_buff;
4817 }
4818 #if 0
4819 }
4820 #endif
4821
4822 hp = NULL;
4823 h = exit_hdlrs;
4824 /* Search handler, remove if not function 2 */
4825 while (h != NULL) {
4826 if (h->proc == *p) {
4827 /* Return priority of installed handler */
4828 if (*install_flag == 2) {
4829 #if 0 /* TODO: take care of ACU variant: priority in return */
4830 if (something) {
4831 return priority;
4832 }
4833 #endif
4834 memcpy ((void *)(&priority), &h->priority, sizeof (unsigned char));
4835 return 0;
4836 }
4837 if (hp != NULL) {
4838 hp->next = h->next;
4839 } else {
4840 exit_hdlrs = h->next;
4841 }
4842 cob_free (h);
4843 /* Remove handler --> done */
4844 if (*install_flag == 1) {
4845 return 0;
4846 }
4847 break;
4848 }
4849 hp = h;
4850 h = h->next;
4851 }
4852 if (*install_flag == 2) {
4853 #if 0 /* TODO: take care of ACU variant: priority 255 = not availabe */
4854 if (something) {
4855 return 255;
4856 }
4857 #endif
4858 return -1;
4859 }
4860 h = cob_malloc (sizeof (struct exit_handlerlist));
4861 h->next = exit_hdlrs;
4862 h->proc = *p;
4863 memcpy (&h->priority, priority, sizeof (unsigned char));
4864 exit_hdlrs = h;
4865 return 0;
4866 }
4867
4868 int
4869 cob_sys_error_proc (const void *dispo, const void *pptr)
4870 {
4871 struct handlerlist *hp;
4872 struct handlerlist *h;
4873 const unsigned char *x;
4874 int (**p) (char *s);
4875
4876 COB_CHK_PARMS (CBL_ERROR_PROC, 2);
4877
4878 #if 0 /* TODO: take care of ACU variant:
4879 pptr is not an already resolved entry point
4880 but a name which is to be cob_resolve'd (at use-time);
4881 maybe resolve here and return -1 if not possible */
4882 if (something) {
4883 const char *name = (char *)pptr;
4884 pptr = cob_resolve_cobol (name, 0, 0);
4885 if (!p) {
4886 return -1;
4887 }
4888 } else {
4889 #endif
4890 memcpy (&p, &pptr, sizeof (void *));
4891 if (!p || !*p) {
4892 return -1;
4893 }
4894 #if 0
4895 }
4896 #endif
4897
4898 hp = NULL;
4899 h = hdlrs;
4900 /* Search for existing handler */
4901 while (h != NULL) {
4902 if (h->proc == *p) {
4903 break;
4904 }
4905 hp = h;
4906 h = h->next;
4907 }
4908 x = dispo;
4909 if (*x != 0) {
4910 /* Remove handler */
4911 if (h != NULL) {
4912 if (hp != NULL) {
4913 hp->next = h->next;
4914 } else {
4915 hdlrs = h->next;
4916 }
4917 cob_free (h);
4918 }
4919 } else {
4920 if (h == NULL) {
4921 /* insert handler */
4922 h = cob_malloc (sizeof (struct handlerlist));
4923 h->next = hdlrs;
4924 h->proc = *p;
4925 hdlrs = h;
4926 } else {
4927 #if 0 /* TODO: take care of ACU variant: placing it first */
4928 if (something) {
4929 if (hp != NULL) {
4930 hp->next = h->next;
4931 }
4932 h->next = hdlrs;
4933 hdlrs = h;
4934 } else {
4935 /* MF-Variant: when already existing: do nothing */
4936 return 0;
4937 }
4938 #else
4939 /* MF-Variant: when already existing: do nothing */
4940 return 0;
4941 #endif
4942 }
4943 }
4944 return 0;
4945 }
4946
4947 int
4948 cob_sys_system (const void *cmdline)
4949 {
4950 COB_CHK_PARMS (SYSTEM, 1);
4951
4952 if (COB_MODULE_PTR->cob_procedure_params[0]) {
4953 const char* cmd = cmdline;
4954 size_t i = COB_MODULE_PTR->cob_procedure_params[0]->size;
4955
4956 i--;
4957 do {
4958 if (cmd[i] != ' ' && cmd[i] != 0) {
4959 break;
4960 }
4961 } while (--i != 0);
4962 if (i > 0) {
4963 char *command;
4964 /* LCOV_EXCL_START */
4965 if (unlikely (i > COB_MEDIUM_MAX)) {
4966 cob_runtime_warning (_("parameter to SYSTEM call is larger than %d characters"), COB_MEDIUM_MAX);
4967 return 1;
4968 }
4969 /* LCOV_EXCL_STOP */
4970 #ifdef _WIN32
4971 /* All known _WIN32 implementations use MSVCRT's system()
4972 which passes the given commandline as parameter to "cmd /k".
4973 Because "of compatibility" this checks if you have a
4974 leading and trailing " and if yes simply removes them (!).
4975 Check if this is the case and if it is handled already
4976 by an *extra* pair of quotes, otherwise add these...
4977 */
4978 if (i > 2 && cmd[0] == '"' && cmd[i] == '"'
4979 && (cmd[1] != '"' || cmd[i - 1] != '"')) {
4980 command = cob_malloc ((size_t)i + 4);
4981 command[0] = '"';
4982 memcpy (command + 1, cmd, (size_t)i + 1);
4983 command[i + 1] = '"';
4984 } else {
4985 #endif /* _WIN32 */
4986 command = cob_malloc ((size_t)i + 2);
4987 memcpy (command, cmd, (size_t)i + 1);
4988 #ifdef _WIN32
4989 }
4990 #endif
4991 {
4992 int status;
4993 if (cobglobptr->cob_screen_initialized) {
4994 cob_screen_set_mode (0);
4995 }
4996 /* note: if the command cannot be executed _WIN32 always returns 1
4997 while GNU/Linux returns -1 */
4998 status = system (command);
4999 if (cobglobptr->cob_screen_initialized) {
5000 cob_screen_set_mode (1U);
5001 }
5002 #ifdef WIFSIGNALED
5003 if (WIFSIGNALED (status)) {
5004 int signal_value = WTERMSIG (status);
5005 const char * signal_name = get_signal_name (signal_value);
5006 /* LCOV_EXCL_START */
5007 if (!signal_name) {
5008 signal_name = _("unknown");
5009 }
5010 /* LCOV_EXCL_STOP */
5011 cob_runtime_warning (_("external process \"%s\" ended with signal %s (%d)"),
5012 command, signal_name, signal_value);
5013 }
5014 #endif
5015 cob_free (command);
5016 #if 0 /* possibly do this, but only if explicit asked for via a new runtime configuration
5017 as at least MicroFocus always returns all bytes here;
5018 from its docs it _looks_ like ACU only return the lower bytes ... */
5019 #ifdef WEXITSTATUS
5020 if (WIFEXITED (status)) {
5021 status = WEXITSTATUS (status);
5022 }
5023 #endif
5024 #endif
5025 return status;
5026 }
5027 }
5028 }
5029 return 1;
5030 }
5031
5032 /**
5033 * Return some hosted C variables, argc, argv, stdin, stdout, stderr.
5034 */
5035 int
5036 cob_sys_hosted (void *p, const void *var)
5037 {
5038 const char *name = var;
5039 cob_u8_ptr data = p;
5040 size_t i;
5041
5042 COB_CHK_PARMS (CBL_GC_HOSTED, 2);
5043
5044 if (!data) {
5045 return 1;
5046 }
5047
5048 if (COB_MODULE_PTR->cob_procedure_params[1]) {
5049 i = (int)COB_MODULE_PTR->cob_procedure_params[1]->size;
5050 if ((i == 4) && !strncmp (name, "argc", 4)) {
5051 *((int *)data) = cob_argc;
5052 return 0;
5053 }
5054 if ((i == 4) && !strncmp (name, "argv", 4)) {
5055 *((char ***)data) = cob_argv;
5056 return 0;
5057 }
5058 if ((i == 5) && !strncmp (name, "stdin", 5)) {
5059 *((FILE **)data) = stdin;
5060 return 0;
5061 }
5062 if ((i == 6) && !strncmp (name, "stdout", 6)) {
5063 *((FILE **)data) = stdout;
5064 return 0;
5065 }
5066 if ((i == 6) && !strncmp (name, "stderr", 6)) {
5067 *((FILE **)data) = stderr;
5068 return 0;
5069 }
5070 if ((i == 5) && !strncmp (name, "errno", 5)) {
5071 *((int **)data) = &errno;
5072 return 0;
5073 }
5074 #if defined (HAVE_TIMEZONE)
5075 if ((i == 6) && !strncmp (name, "tzname", 6)) {
5076 /* Recheck: bcc raises "suspicious pointer conversion */
5077 *((char ***)data) = tzname;
5078 return 0;
5079 }
5080 if ((i == 8) && !strncmp (name, "timezone", 8)) {
5081 *((long *)data) = timezone;
5082 return 0;
5083 }
5084 if ((i == 8) && !strncmp (name, "daylight", 8)) {
5085 *((int *)data) = daylight;
5086 return 0;
5087 }
5088 #endif /* HAVE_TIMEZONE */
5089 }
5090 return 1;
5091 }
5092
5093 int
5094 cob_sys_and (const void *p1, void *p2, const int length)
5095 {
5096 const cob_u8_ptr data_1 = p1;
5097 cob_u8_ptr data_2 = p2;
5098 size_t n;
5099
5100 COB_CHK_PARMS (CBL_AND, 3);
5101
5102 if (length <= 0) {
5103 return 0;
5104 }
5105 for (n = 0; n < (size_t)length; ++n) {
5106 data_2[n] &= data_1[n];
5107 }
5108 return 0;
5109 }
5110
5111 int
5112 cob_sys_or (const void *p1, void *p2, const int length)
5113 {
5114 const cob_u8_ptr data_1 = p1;
5115 cob_u8_ptr data_2 = p2;
5116 size_t n;
5117
5118 COB_CHK_PARMS (CBL_OR, 3);
5119
5120 if (length <= 0) {
5121 return 0;
5122 }
5123 for (n = 0; n < (size_t)length; ++n) {
5124 data_2[n] |= data_1[n];
5125 }
5126 return 0;
5127 }
5128
5129 int
5130 cob_sys_nor (const void *p1, void *p2, const int length)
5131 {
5132 const cob_u8_ptr data_1 = p1;
5133 cob_u8_ptr data_2 = p2;
5134 size_t n;
5135
5136 COB_CHK_PARMS (CBL_NOR, 3);
5137
5138 if (length <= 0) {
5139 return 0;
5140 }
5141 for (n = 0; n < (size_t)length; ++n) {
5142 data_2[n] = ~(data_1[n] | data_2[n]);
5143 }
5144 return 0;
5145 }
5146
5147 int
5148 cob_sys_xor (const void *p1, void *p2, const int length)
5149 {
5150 const cob_u8_ptr data_1 = p1;
5151 cob_u8_ptr data_2 = p2;
5152 size_t n;
5153
5154 COB_CHK_PARMS (CBL_XOR, 3);
5155
5156 if (length <= 0) {
5157 return 0;
5158 }
5159 for (n = 0; n < (size_t)length; ++n) {
5160 data_2[n] ^= data_1[n];
5161 }
5162 return 0;
5163 }
5164
5165 /* COBOL routine to perform for logical IMPLIES between the bits in two fields,
5166 storing the result in the second field */
5167 int
5168 cob_sys_imp (const void *p1, void *p2, const int length)
5169 {
5170 const cob_u8_ptr data_1 = p1;
5171 cob_u8_ptr data_2 = p2;
5172 size_t n;
5173
5174 COB_CHK_PARMS (CBL_IMP, 3);
5175
5176 if (length <= 0) {
5177 return 0;
5178 }
5179 for (n = 0; n < (size_t)length; ++n) {
5180 data_2[n] = (~data_1[n]) | data_2[n];
5181 }
5182 return 0;
5183 }
5184
5185
5186 /* COBOL routine to perform for logical NOT IMPLIES between the bits in two fields,
5187 storing the result in the second field */
5188 int
5189 cob_sys_nimp (const void *p1, void *p2, const int length)
5190 {
5191 const cob_u8_ptr data_1 = p1;
5192 cob_u8_ptr data_2 = p2;
5193 size_t n;
5194
5195 COB_CHK_PARMS (CBL_NIMP, 3);
5196
5197 if (length <= 0) {
5198 return 0;
5199 }
5200 for (n = 0; n < (size_t)length; ++n) {
5201 data_2[n] = data_1[n] & (~data_2[n]);
5202 }
5203 return 0;
5204 }
5205
5206 /* COBOL routine to check for logical EQUIVALENCE between the bits in two fields,
5207 storing the result in the second field */
5208 int
5209 cob_sys_eq (const void *p1, void *p2, const int length)
5210 {
5211 const cob_u8_ptr data_1 = p1;
5212 cob_u8_ptr data_2 = p2;
5213 size_t n;
5214
5215 COB_CHK_PARMS (CBL_EQ, 3);
5216
5217 if (length <= 0) {
5218 return 0;
5219 }
5220 for (n = 0; n < (size_t)length; ++n) {
5221 data_2[n] = ~(data_1[n] ^ data_2[n]);
5222 }
5223 return 0;
5224 }
5225
5226 /* COBOL routine to perform a logical NOT on the bits of a field */
5227 int
5228 cob_sys_not (void *p1, const int length)
5229 {
5230 cob_u8_ptr data_1 = p1;
5231 size_t n;
5232
5233 COB_CHK_PARMS (CBL_NOT, 2);
5234
5235 if (length <= 0) {
5236 return 0;
5237 }
5238 for (n = 0; n < (size_t)length; ++n) {
5239 data_1[n] = ~data_1[n];
5240 }
5241 return 0;
5242 }
5243
5244 /* COBOL routine to pack the least significant bits in eight bytes into a single byte */
5245 int
5246 cob_sys_xf4 (void *p1, const void *p2)
5247 {
5248 cob_u8_ptr data_1 = p1;
5249 const cob_u8_ptr data_2 = p2;
5250 size_t n;
5251
5252 COB_CHK_PARMS (CBL_XF4, 2);
5253
5254 *data_1 = 0;
5255 for (n = 0; n < 8; ++n) {
5256 *data_1 |= (data_2[n] & 1) << (7 - n);
5257 }
5258 return 0;
5259 }
5260
5261 /* COBOL routine to unpack the bits in a byte into eight bytes */
5262 int
5263 cob_sys_xf5 (const void *p1, void *p2)
5264 {
5265 const cob_u8_ptr data_1 = p1;
5266 cob_u8_ptr data_2 = p2;
5267 size_t n;
5268
5269 COB_CHK_PARMS (CBL_XF5, 2);
5270
5271 for (n = 0; n < 8; ++n) {
5272 data_2[n] = (*data_1 & (1 << (7 - n))) ? 1 : 0;
5273 }
5274 return 0;
5275 }
5276
5277 /* COBOL routine for different functions, including functions for
5278 the programmable COBOL SWITCHES:
5279 11: set COBOL switches 0-7
5280 12: read COBOL switches 0-7
5281 16: return number of CALL USING parameters
5282 */
5283 int
5284 cob_sys_x91 (void *p1, const void *p2, void *p3)
5285 {
5286 cob_u8_ptr result = p1;
5287 const cob_u8_ptr func = p2;
5288 cob_u8_ptr parm = p3;
5289 unsigned char *p;
5290 size_t i;
5291
5292 switch (*func) {
5293
5294 /* Set switches (0-7) */
5295 case 11:
5296 p = parm;
5297 for (i = 0; i < 8; ++i, ++p) {
5298 if (*p == 0) {
5299 cob_switch[i] = 0;
5300 } else if (*p == 1) {
5301 cob_switch[i] = 1;
5302 }
5303 }
5304 /* INSPECT: MF additionally sets the ANSI DEBUG module switch */
5305 *result = 0;
5306 break;
5307
5308 /* Get switches (0-7) */
5309 case 12:
5310 p = parm;
5311 for (i = 0; i < 8; ++i, ++p) {
5312 *p = (unsigned char)cob_switch[i];
5313 }
5314 /* INSPECT: MF additionally reads the ANSI DEBUG module switch */
5315 *result = 0;
5316 break;
5317
5318 /* Return number of call parameters
5319 according to the docs this is only set for programs CALLed from COBOL
5320 NOT for main programs in contrast to C$NARG (cob_sys_return_args)
5321 */
5322 case 16:
5323 *parm = (unsigned char)COB_MODULE_PTR->module_num_params;
5324 *result = 0;
5325 break;
5326
5327 /* unimplemented function,
5328 note: 46-49 may be implemented after fileio-specific merge of rw-branch
5329 35 (EXEC) and 15 (program lookup) may be implemented as soon as some legacy code
5330 shows its exact use and a test case */
5331 default:
5332 *result = 1;
5333 break;
5334 }
5335 return 0;
5336 }
5337
5338 int
5339 cob_sys_toupper (void *p1, const int length)
5340 {
5341 cob_u8_ptr data = p1;
5342 size_t n;
5343
5344 COB_CHK_PARMS (CBL_TOUPPER, 2);
5345
5346 if (length > 0) {
5347 for (n = 0; n < (size_t)length; ++n) {
5348 if (islower (data[n])) {
5349 data[n] = (cob_u8_t)toupper (data[n]);
5350 }
5351 }
5352 }
5353 return 0;
5354 }
5355
5356 int
5357 cob_sys_tolower (void *p1, const int length)
5358 {
5359 cob_u8_ptr data = p1;
5360 size_t n;
5361
5362 COB_CHK_PARMS (CBL_TOLOWER, 2);
5363
5364 if (length > 0) {
5365 for (n = 0; n < (size_t)length; ++n) {
5366 if (isupper (data[n])) {
5367 data[n] = (cob_u8_t)tolower (data[n]);
5368 }
5369 }
5370 }
5371 return 0;
5372 }
5373
5374 /* maximum sleep time in seconds, currently 7 days */
5375 #define MAX_SLEEP_TIME 3600*24*7
5376
5377 static cob_s64_t
5378 get_sleep_nanoseconds (cob_field *nano_seconds) {
5379
5380 cob_s64_t nanoseconds = cob_get_llint (nano_seconds);
5381
5382 if (nanoseconds < 0) {
5383 return -1;
5384 }
5385 if (nanoseconds >= ((cob_s64_t)MAX_SLEEP_TIME * 1000000000)) {
5386 return (cob_s64_t)MAX_SLEEP_TIME * 1000000000;
5387 } else {;
5388 return nanoseconds;
5389 }
5390 }
5391
5392 static cob_s64_t
5393 get_sleep_nanoseconds_from_seconds (cob_field *decimal_seconds) {
5394
5395 #define MAX_SLEEP_TIME 3600*24*7
5396 cob_s64_t seconds = cob_get_llint (decimal_seconds);
5397
5398 if (seconds < 0) {
5399 return -1;
5400 }
5401 if (seconds >= MAX_SLEEP_TIME) {
5402 return (cob_s64_t)MAX_SLEEP_TIME * 1000000000;
5403 } else {
5404 cob_s64_t nanoseconds;
5405 cob_field temp;
5406 temp.size = 8;
5407 temp.data = (unsigned char *)&nanoseconds;
5408 temp.attr = &const_bin_nano_attr;
5409 cob_move (decimal_seconds, &temp);
5410 return nanoseconds;
5411 }
5412 }
5413
5414 static void
5415 internal_nanosleep (cob_s64_t nsecs)
5416 {
5417 #ifdef HAVE_NANO_SLEEP
5418 struct timespec tsec;
5419
5420 tsec.tv_sec = nsecs / 1000000000;
5421 tsec.tv_nsec = nsecs % 1000000000;
5422 nanosleep (&tsec, NULL);
5423
5424 #else
5425
5426 unsigned int msecs;
5427 #if defined (__370__) || defined (__OS400__)
5428 msecs = (unsigned int)(nsecs / 1000000000);
5429 if (msecs > 0) {
5430 sleep (msecs);
5431 }
5432 #elif defined (_WIN32)
5433 msecs = (unsigned int)(nsecs / 1000000);
5434 if (msecs > 0) {
5435 Sleep (msecs);
5436 }
5437 #else
5438 msecs = (unsigned int)(nsecs / 1000000000);
5439 if (msecs > 0) {
5440 sleep (msecs);
5441 }
5442 #endif
5443 #endif
5444 }
5445
5446 /* CBL_GC_NANOSLEEP / CBL_OC_NANOSLEEP, origin: OpenCOBOL */
5447 int
5448 cob_sys_oc_nanosleep (const void *data)
5449 {
5450 COB_UNUSED (data);
5451 COB_CHK_PARMS (CBL_GC_NANOSLEEP, 1);
5452
5453 if (COB_MODULE_PTR->cob_procedure_params[0]) {
5454 cob_s64_t nsecs
5455 = get_sleep_nanoseconds (COB_MODULE_PTR->cob_procedure_params[0]);
5456 if (nsecs > 0) {
5457 internal_nanosleep (nsecs);
5458 }
5459 return 0;
5460 }
5461 return -1;
5462 }
5463
5464 /* C$SLEEP, origin: ACUCOBOL */
5465 int
5466 cob_sys_sleep (const void *data)
5467 {
5468 COB_UNUSED (data);
5469 COB_CHK_PARMS (C$SLEEP, 1);
5470
5471 if (COB_MODULE_PTR->cob_procedure_params[0]) {
5472 cob_s64_t nanoseconds
5473 = get_sleep_nanoseconds_from_seconds (COB_MODULE_PTR->cob_procedure_params[0]);
5474 if (nanoseconds < 0) {
5475 /* ACUCOBOL specifies a runtime error here... */
5476 return -1;
5477 }
5478 internal_nanosleep (nanoseconds);
5479 return 0;
5480 }
5481 return 0; /* CHECKME */
5482 }
5483
5484 int
5485 cob_sys_getpid (void)
5486 {
5487 if (!cob_process_id) {
5488 cob_process_id = (int)getpid ();
5489 }
5490 return cob_process_id;
5491 }
5492
5493 int
5494 cob_sys_fork (void)
5495 {
5496 /* cygwin does not define _WIN32, but implements [slow] fork() and provides unistd.h
5497 MSYS defines _WIN32, provides unistd.h and not implements fork()
5498 */
5499 #if defined (HAVE_UNISTD_H) && !(defined (_WIN32))
5500 int pid;
5501 if ((pid = fork ()) == 0 ) {
5502 cob_process_id = 0; /* reset cached value */
5503 return 0; /* child process just returns */
5504 }
5505 if (pid < 0) { /* Some error happened */
5506 cob_runtime_warning (_("error '%s' during CBL_GC_FORK"), cob_get_strerror ());
5507 return -2;
5508 }
5509 return pid; /* parent gets process id of child */
5510 #else
5511 cob_runtime_warning (_("'%s' is not supported on this platform"), "CBL_GC_FORK");
5512 return -1;
5513 #endif
5514 }
5515
5516
5517 /* wait for a pid to end and return its exit code
5518 error codes are returned as negative value
5519 */
5520 int
5521 cob_sys_waitpid (const void *p_id)
5522 {
5523 #ifdef HAVE_SYS_WAIT_H
5524 int pid, status, wait_sts;
5525
5526 COB_UNUSED (p_id);
5527
5528 if (COB_MODULE_PTR->cob_procedure_params[0]) {
5529 pid = cob_get_int (COB_MODULE_PTR->cob_procedure_params[0]);
5530 if (pid == cob_sys_getpid ()) {
5531 status = 0 - EINVAL;
5532 return status;
5533 }
5534 wait_sts = waitpid (pid, &status, 0);
5535 if (wait_sts < 0) { /* Some error happened */
5536 status = 0 - errno;
5537 cob_runtime_warning (_("error '%s' for P%d during CBL_GC_WAITPID"),
5538 cob_get_strerror (), pid);
5539 return status;
5540 }
5541 status = WEXITSTATUS (status);
5542 } else {
5543 status = 0 - EINVAL;
5544 }
5545 return status;
5546 #elif defined (_WIN32)
5547 int pid, status;
5548 HANDLE process = NULL;
5549 DWORD ret;
5550
5551 COB_UNUSED (p_id);
5552
5553 status = 0;
5554 if (COB_MODULE_PTR->cob_procedure_params[0]) {
5555 pid = cob_get_int (COB_MODULE_PTR->cob_procedure_params[0]);
5556 if (pid == cob_sys_getpid ()) {
5557 status = 0 - ERROR_INVALID_DATA;
5558 return status;
5559 }
5560 /* get process handle with least necessary rights
5561 PROCESS_QUERY_LIMITED_INFORMATION is available since OS-version Vista / Server 2008
5562 and always leads to ERROR_ACCESS_DENIED on older systems
5563 PROCESS_QUERY_INFORMATION needs more rights
5564 SYNCHRONIZE necessary for WaitForSingleObject
5565 */
5566 #if defined (PROCESS_QUERY_LIMITED_INFORMATION)
5567 process = OpenProcess (SYNCHRONIZE | PROCESS_QUERY_LIMITED_INFORMATION, FALSE, pid);
5568 #if !defined (_MSC_VER) || COB_USE_VC2012_OR_GREATER /* only try a higher level if we possibly compile on XP/2003 */
5569 /* TODO: check what happens on WinXP / 2003 as PROCESS_QUERY_LIMITED_INFORMATION isn't available there */
5570 if (!process && GetLastError () == ERROR_ACCESS_DENIED) {
5571 process = OpenProcess (SYNCHRONIZE | PROCESS_QUERY_INFORMATION, FALSE, pid);
5572 }
5573 #endif
5574 #else
5575 process = OpenProcess (SYNCHRONIZE | PROCESS_QUERY_INFORMATION, FALSE, pid);
5576 #endif
5577 /* if we don't get access to query the process' exit status try to get at least
5578 access to the process end (needed for WaitForSingleObject)
5579 */
5580 if (!process && GetLastError () == ERROR_ACCESS_DENIED) {
5581 process = OpenProcess (SYNCHRONIZE, FALSE, pid);
5582 status = -2;
5583 }
5584 if (process) {
5585 /* wait until process exit */
5586 ret = WaitForSingleObject (process, INFINITE);
5587 if (ret == WAIT_FAILED) {
5588 status = 0 - GetLastError ();
5589 /* get exit code, if possible */
5590 } else if (status != -2) {
5591 if (!GetExitCodeProcess (process, &ret)) {
5592 status = 0 - GetLastError ();
5593 } else {
5594 status = (int) ret;
5595 }
5596 }
5597 CloseHandle (process);
5598 } else {
5599 status = 0 - GetLastError ();
5600 }
5601 } else {
5602 status = 0 - ERROR_INVALID_DATA;
5603 }
5604 return status;
5605 #else
5606 COB_UNUSED (p_id);
5607
5608 cob_runtime_warning (_("'%s' is not supported on this platform"), "CBL_GC_WAITPID");
5609 return -1;
5610 #endif
5611 }
5612
5613 /* set the number of arguments passed to the current program;
5614 works both for main programs and called sub programs
5615 Implemented according to ACUCOBOL-GT -> returns the number of arguments that were passed,
5616 not like in MF implementation the number of arguments that were received */
5617 int
5618 cob_sys_return_args (void *data)
5619 {
5620 COB_UNUSED (data);
5621
5622 COB_CHK_PARMS (C$NARG, 1);
5623
5624 if (COB_MODULE_PTR->cob_procedure_params[0]) {
5625 cob_set_int (COB_MODULE_PTR->cob_procedure_params[0],
5626 COB_MODULE_PTR->module_num_params);
5627 }
5628 return 0;
5629 }
5630
5631 int
5632 cob_sys_calledby (void *data)
5633 {
5634 size_t size;
5635 size_t msize;
5636
5637 COB_CHK_PARMS (C$CALLEDBY, 1);
5638
5639 if (!COB_MODULE_PTR->cob_procedure_params[0]) {
5640 /* TO-DO: check what ACU ccbl/runcbl returns,
5641 the documentation doesn't say anything about this */
5642 return -1;
5643 }
5644 size = COB_MODULE_PTR->cob_procedure_params[0]->size;
5645 memset (data, ' ', size);
5646 if (!COB_MODULE_PTR->next) {
5647 return 0;
5648 }
5649 msize = strlen (COB_MODULE_PTR->next->module_name);
5650 if (msize > size) {
5651 msize = size;
5652 }
5653 memcpy (data, COB_MODULE_PTR->next->module_name, msize);
5654 return 1;
5655 }
5656
5657 int
5658 cob_sys_parameter_size (void *data)
5659 {
5660 int n;
5661
5662 COB_UNUSED (data);
5663
5664 COB_CHK_PARMS (C$PARAMSIZE, 1);
5665
5666 if (COB_MODULE_PTR->cob_procedure_params[0]) {
5667 n = cob_get_int (COB_MODULE_PTR->cob_procedure_params[0]);
5668 if (n > 0 && n <= COB_MODULE_PTR->module_num_params) {
5669 n--;
5670 if (COB_MODULE_PTR->next
5671 && COB_MODULE_PTR->next->cob_procedure_params[n]) {
5672 return (int)COB_MODULE_PTR->next->cob_procedure_params[n]->size;
5673 }
5674 }
5675 }
5676 return 0;
5677 }
5678
5679 int
5680 cob_sys_getopt_long_long (void *so, void *lo, void *idx, const int long_only, void *return_char, void *opt_val)
5681 {
5682 /*
5683 * cob_argc is a static int containing argc from runtime
5684 * cob_argv is a static char ** containing argv from runtime
5685 */
5686
5687 size_t opt_val_size = 0;
5688 size_t so_size = 0;
5689 size_t lo_size = 0;
5690
5691 unsigned int lo_amount;
5692 int exit_status;
5693
5694 char *shortoptions;
5695 char *temp;
5696
5697 struct option *longoptions, *longoptions_root;
5698 longoption_def *l = NULL;
5699
5700 int longind = 0;
5701 unsigned int i;
5702 int j;
5703
5704 int return_value;
5705
5706 COB_UNUSED (idx);
5707 COB_UNUSED (lo);
5708 COB_UNUSED (so);
5709
5710 COB_CHK_PARMS (CBL_GC_GETOPT, 6);
5711
5712 /* Read in sizes of some parameters */
5713 if (COB_MODULE_PTR->cob_procedure_params[1]) {
5714 lo_size = COB_MODULE_PTR->cob_procedure_params[1]->size;
5715 }
5716 if (COB_MODULE_PTR->cob_procedure_params[0]) {
5717 so_size = COB_MODULE_PTR->cob_procedure_params[0]->size;
5718 }
5719 if (COB_MODULE_PTR->cob_procedure_params[5]) {
5720 opt_val_size = COB_MODULE_PTR->cob_procedure_params[5]->size;
5721 }
5722
5723 /* buffering longoptions (COBOL), target format (struct option) */
5724 if (lo_size % sizeof (longoption_def) == 0) {
5725 lo_amount = (int)lo_size / sizeof (longoption_def);
5726 longoptions_root = (struct option*) cob_malloc (sizeof (struct option) * ((size_t)lo_amount + 1U));
5727 } else {
5728 cob_runtime_error (_("Call to CBL_GC_GETOPT with wrong longoption size."));
5729 cob_stop_run (1);
5730 }
5731
5732 if (!COB_MODULE_PTR->cob_procedure_params[2]) {
5733 cob_runtime_error (_("Call to CBL_GC_GETOPT with missing longind."));
5734 cob_stop_run (1);
5735 }
5736 longind = cob_get_int (COB_MODULE_PTR->cob_procedure_params[2]);
5737
5738 /* add 0-termination to strings */
5739 shortoptions = cob_malloc (so_size + 1U);
5740 if (COB_MODULE_PTR->cob_procedure_params[0]) {
5741 cob_field_to_string (COB_MODULE_PTR->cob_procedure_params[0], shortoptions, so_size);
5742 }
5743
5744 if (COB_MODULE_PTR->cob_procedure_params[1]) {
5745 l = (struct __longoption_def*) (COB_MODULE_PTR->cob_procedure_params[1]->data);
5746 }
5747
5748 longoptions = longoptions_root;
5749 for (i = 0; i < lo_amount; i++) {
5750 j = sizeof (l->name) - 1;
5751 while (j >= 0 && l->name[j] == 0x20) {
5752 l->name[j] = 0x00;
5753 j--;
5754 }
5755 longoptions->name = l->name;
5756 longoptions->has_arg = (int) l->has_option - '0';
5757 memcpy (&longoptions->flag, l->return_value_pointer, sizeof (l->return_value_pointer));
5758 memcpy (&longoptions->val, &l->return_value, 4);
5759
5760 l = l + 1; /* +1 means pointer + 1*sizeof (longoption_def) */
5761 longoptions = longoptions + 1;
5762 }
5763
5764 /* appending final record, so getopt can spot the end of longoptions */
5765 longoptions->name = NULL;
5766 longoptions->has_arg = 0;
5767 longoptions->flag = NULL;
5768 longoptions->val = 0;
5769
5770
5771 l -= lo_amount; /* Set pointer back to begin of longoptions */
5772 longoptions -= lo_amount;
5773
5774 return_value = cob_getopt_long_long (cob_argc, cob_argv, shortoptions, longoptions, &longind, long_only);
5775 temp = (char *) &return_value;
5776
5777 /* Write data back to COBOL */
5778 #ifdef WORDS_BIGENDIAN
5779 if (temp[3] == '?'
5780 || temp[3] == ':'
5781 || temp[3] == 'W'
5782 || temp[3] == 0) {
5783 exit_status = temp[3] & 0xFF;
5784 } else if (return_value == -1) {
5785 exit_status = -1;
5786 } else {
5787 exit_status = 3;
5788 }
5789 /* cob_getopt_long_long sometimes returns and 'int' value and sometimes a 'x ' in the int */
5790 if (temp[0] == 0
5791 && temp[1] == 0
5792 && temp[2] == 0) {
5793 /* Move option value to 1st byte and SPACE fill the 'int' */
5794 temp[0] = temp[3];
5795 temp[1] = temp[2] = temp[3] = ' ';
5796 }
5797 #else
5798 if (temp[0] == '?'
5799 || temp[0] == ':'
5800 || temp[0] == 'W'
5801 || temp[0] == -1
5802 || temp[0] == 0) {
5803 exit_status = return_value;
5804 } else {
5805 exit_status = 3;
5806 }
5807
5808 for (i = 3; i > 0; i--) {
5809 if (temp[i] == 0) temp[i] = ' ';
5810 else break;
5811 }
5812 #endif
5813
5814 cob_set_int (COB_MODULE_PTR->cob_procedure_params[2], longind);
5815 memcpy (return_char, &return_value, 4);
5816
5817 if (cob_optarg != NULL) {
5818 size_t optlen;
5819 memset (opt_val, 0, opt_val_size);
5820
5821 optlen = strlen (cob_optarg);
5822 if (optlen > opt_val_size) {
5823 /* Return code 2 for "Option value too long => cut" */
5824 optlen = opt_val_size;
5825 exit_status = 2;
5826 }
5827 memcpy (opt_val, cob_optarg, optlen);
5828 }
5829
5830 cob_free (shortoptions);
5831 cob_free (longoptions_root);
5832
5833 return exit_status;
5834 }
5835
5836 int
5837 cob_sys_printable (void *p1, ...)
5838 {
5839 cob_u8_ptr data;
5840 unsigned char *dotptr;
5841 size_t datalen;
5842 size_t n;
5843 unsigned char dotrep;
5844 va_list args;
5845
5846 COB_CHK_PARMS (CBL_GC_PRINTABLE, 1);
5847
5848 if (!COB_MODULE_PTR->cob_procedure_params[0]) {
5849 return 0;
5850 }
5851 data = p1;
5852 datalen = COB_MODULE_PTR->cob_procedure_params[0]->size;
5853 if (cobglobptr->cob_call_params > 1) {
5854 va_start (args, p1);
5855 dotptr = va_arg (args, unsigned char *);
5856 va_end (args);
5857 dotrep = *dotptr;
5858 } else {
5859 dotrep = (unsigned char)'.';
5860 }
5861 for (n = 0; n < datalen; ++n) {
5862 if (!isprint (data[n])) {
5863 data[n] = dotrep;
5864 }
5865 }
5866 return 0;
5867 }
5868
5869 int
5870 cob_sys_justify (void *p1, ...)
5871 {
5872 cob_u8_ptr data;
5873 size_t datalen;
5874 size_t left;
5875 size_t right;
5876 size_t movelen;
5877 size_t centrelen;
5878 size_t n;
5879 size_t shifting;
5880
5881 COB_CHK_PARMS (C$JUSTIFY, 1);
5882
5883 if (!COB_MODULE_PTR->cob_procedure_params[0]) {
5884 return 0;
5885 }
5886 data = p1;
5887 datalen = COB_MODULE_PTR->cob_procedure_params[0]->size;
5888 if (datalen < 2) {
5889 return 0;
5890 }
5891 if (data[0] != ' ' && data[datalen - 1] != ' ') {
5892 return 0;
5893 }
5894 for (left = 0; left < datalen; ++left) {
5895 if (data[left] != ' ') {
5896 break;
5897 }
5898 }
5899 if (left == datalen) {
5900 return 0;
5901 }
5902 right = 0;
5903 for (n = datalen - 1; ; --n, ++right) {
5904 if (data[n] != ' ') {
5905 break;
5906 }
5907 if (n == 0) {
5908 break;
5909 }
5910 }
5911 movelen = datalen - left - right;
5912 shifting = 0;
5913 if (cobglobptr->cob_call_params > 1) {
5914 unsigned char *direction;
5915 va_list args;
5916 va_start (args, p1);
5917 direction = va_arg (args, unsigned char *);
5918 va_end (args);
5919 if (*direction == 'L') {
5920 shifting = 1;
5921 } else if (*direction == 'C') {
5922 shifting = 2;
5923 }
5924 }
5925 switch (shifting) {
5926 case 1:
5927 memmove (data, &data[left], movelen);
5928 memset (&data[movelen], ' ', datalen - movelen);
5929 break;
5930 case 2:
5931 centrelen = (left + right) / 2;
5932 memmove (&data[centrelen], &data[left], movelen);
5933 memset (data, ' ', centrelen);
5934 if ((left + right) % 2) {
5935 memset (&data[centrelen + movelen], ' ', centrelen + 1);
5936 } else {
5937 memset (&data[centrelen + movelen], ' ', centrelen);
5938 }
5939 break;
5940 default:
5941 memmove (&data[left + right], &data[left], movelen);
5942 memset (data, ' ', datalen - movelen);
5943 break;
5944 }
5945 return 0;
5946 }
5947
5948 void
5949 cob_set_locale (cob_field *locale, const int category)
5950 {
5951 #ifdef HAVE_SETLOCALE
5952 char *p;
5953 char *buff;
5954
5955 p = NULL;
5956 if (locale) {
5957 if (locale->size == 0) {
5958 return;
5959 }
5960 buff = cob_malloc (locale->size + 1U);
5961 cob_field_to_string (locale, buff, locale->size);
5962 } else {
5963 buff = NULL;
5964 }
5965
5966 switch (category) {
5967 case COB_LC_COLLATE:
5968 p = setlocale (LC_COLLATE, buff);
5969 break;
5970 case COB_LC_CTYPE:
5971 p = setlocale (LC_CTYPE, buff);
5972 break;
5973 #ifdef LC_MESSAGES
5974 case COB_LC_MESSAGES:
5975 p = setlocale (LC_MESSAGES, buff);
5976 break;
5977 #endif
5978 case COB_LC_MONETARY:
5979 p = setlocale (LC_MONETARY, buff);
5980 break;
5981 case COB_LC_NUMERIC:
5982 p = setlocale (LC_NUMERIC, buff);
5983 break;
5984 case COB_LC_TIME:
5985 p = setlocale (LC_TIME, buff);
5986 break;
5987 case COB_LC_ALL:
5988 p = setlocale (LC_ALL, buff);
5989 break;
5990 case COB_LC_USER:
5991 if (cobglobptr->cob_locale_orig) {
5992 p = setlocale (LC_ALL, cobglobptr->cob_locale_orig);
5993 (void)setlocale (LC_NUMERIC, "C");
5994 }
5995 break;
5996 case COB_LC_CLASS:
5997 if (cobglobptr->cob_locale_ctype) {
5998 p = setlocale (LC_CTYPE, cobglobptr->cob_locale_ctype);
5999 }
6000 break;
6001 }
6002 if (buff) {
6003 cob_free (buff);
6004 }
6005 if (!p) {
6006 cob_set_exception (COB_EC_LOCALE_MISSING);
6007 return;
6008 }
6009 p = setlocale (LC_ALL, NULL);
6010 if (p) {
6011 if (cobglobptr->cob_locale) {
6012 cob_free (cobglobptr->cob_locale);
6013 }
6014 cobglobptr->cob_locale = cob_strdup (p);
6015 }
6016 #else
6017 cob_set_exception (COB_EC_LOCALE_MISSING);
6018 #endif
6019 }
6020
6021
6022 #if 0 /* currently not used */
6023 char *
6024 cob_int_to_string (int i, char *number)
6025 {
6026 if (!number) return NULL;
6027 sprintf (number, "%i", i);
6028 return number;
6029 }
6030
6031 char *
6032 cob_int_to_formatted_bytestring (int i, char *number)
6033 {
6034 double d;
6035 char *byte_unit;
6036
6037 if (!number) return NULL;
6038
6039 byte_unit = (char *) cob_fast_malloc (3);
6040
6041 if (i > (1024 * 1024)) {
6042 d = i / 1024.0 / 1024.0;
6043 byte_unit = (char *) "MB";
6044 } else if (i > 1024) {
6045 d = i / 1024.0;
6046 byte_unit = (char *) "kB";
6047 } else {
6048 d = 0;
6049 byte_unit = (char *) "B";
6050 }
6051 sprintf (number, "%3.2f %s", d, byte_unit);
6052 return number;
6053 }
6054 #endif
6055
6056 /* concatenate two strings allocating a new one
6057 and optionally free one of the strings
6058 set str_to_free if the result is assigned to
6059 one of the two original strings
6060 */
6061 char *
6062 cob_strcat (char *str1, char *str2, int str_to_free)
6063 {
6064 size_t l;
6065 char *temp1, *temp2;
6066
6067 l = strlen (str1) + strlen (str2) + 1;
6068
6069 /*
6070 * If one of the parameter is the buffer itself,
6071 * we copy the buffer before continuing.
6072 */
6073 if (str1 == strbuff) {
6074 temp1 = cob_strdup (str1);
6075 } else {
6076 temp1 = str1;
6077 }
6078 if (str2 == strbuff) {
6079 temp2 = cob_strdup (str2);
6080 } else {
6081 temp2 = str2;
6082 }
6083
6084 if (strbuff) {
6085 cob_free (strbuff);
6086 }
6087 strbuff = (char *) cob_fast_malloc (l);
6088
6089 sprintf (strbuff, "%s%s", temp1, temp2);
6090 switch (str_to_free) {
6091 case 1: cob_free (temp1);
6092 break;
6093 case 2: cob_free (temp2);
6094 break;
6095 default: break;
6096 }
6097 return strbuff;
6098 }
6099
6100 char *
6101 cob_strjoin (char **strarray, int size, char *separator)
6102 {
6103 char *result;
6104 int i;
6105
6106 if (!strarray || size <= 0 || !separator) return NULL;
6107
6108 result = cob_strdup (strarray[0]);
6109 for (i = 1; i < size; i++) {
6110 result = cob_strcat (result, separator, 1);
6111 result = cob_strcat (result, strarray[i], 1);
6112 }
6113
6114 return result;
6115 }
6116
6117 static void
6118 var_print (const char *msg, const char *val, const char *default_val,
6119 const unsigned int format)
6120 {
6121 #if 0 /* currently only format 0/1 used */
6122 switch (format) {
6123 case 0:
6124 printf ("%-*.*s : ", CB_IMSG_SIZE, CB_IMSG_SIZE, msg);
6125 break;
6126 case 1: {
6127 int lablen;
6128 printf (" %s: ", _("env"));
6129 lablen = CB_IMSG_SIZE - 2 - (int)strlen (_("env")) - 2;
6130 printf ("%-*.*s : ", lablen, lablen, msg);
6131 break;
6132 }
6133 case 2:
6134 printf (" %-*.*s : ", CB_IMSG_SIZE, CB_IMSG_SIZE, msg);
6135 break;
6136 case 3:
6137 printf (" %-*.*s : ", CB_IMSG_SIZE, CB_IMSG_SIZE, msg);
6138 break;
6139 default:
6140 printf ("%-*.*s : ", CB_IMSG_SIZE, CB_IMSG_SIZE, msg);
6141 break;
6142 }
6143
6144 if (!val && (!default_val || default_val[0] == 0)) {
6145 putchar ('\n');
6146 return;
6147 } else if (format != 0 && val && default_val &&
6148 ((format != 2 && val[0] == '0') || strcmp (val, default_val) == 0)) {
6149 char dflt[40];
6150 snprintf (dflt, 39, " %s", _("(default)"));
6151 val = cob_strcat ((char *) default_val, dflt, 0);
6152 } else if (!val && default_val) {
6153 val = default_val;
6154 }
6155 #else
6156 if (format == 0) {
6157 printf ("%-*.*s : ", CB_IMSG_SIZE, CB_IMSG_SIZE, msg);
6158 } else {
6159 int lablen;
6160 printf (" %s: ", _("env"));
6161 lablen = CB_IMSG_SIZE - 2 - (int)strlen (_("env")) - 2;
6162 printf ("%-*.*s : ", lablen, lablen, msg);
6163 }
6164
6165 if (!val && (!default_val || default_val[0] == 0)) {
6166 putchar ('\n');
6167 return;
6168 } else if (format == 1 && val && default_val &&
6169 (val[0] == '0' || strcmp (val, default_val) == 0)) {
6170 char dflt[40];
6171 snprintf (dflt, 39, " %s", _("(default)"));
6172 val = cob_strcat ((char *) default_val, dflt, 0);
6173 } else if (!val && default_val) {
6174 val = default_val;
6175 }
6176 #endif
6177
6178 if (!val && (!default_val || default_val[0] == 0)) {
6179 putchar ('\n');
6180 return;
6181 } else if (format != 0 && val && default_val &&
6182 ((format != 2 && val[0] == '0') || strcmp (val, default_val) == 0)) {
6183 char dflt[40];
6184 snprintf (dflt, 39, " %s", _("(default)"));
6185 val = cob_strcat ((char *) default_val, dflt, 0);
6186 } else if (!val && default_val) {
6187 val = default_val;
6188 }
6189
6190 if (val && strlen (val) <= CB_IVAL_SIZE) {
6191 printf ("%s", val);
6192 putchar ('\n');
6193
6194 return;
6195 }
6196
6197
6198 {
6199 char *p;
6200 char *token;
6201 size_t n;
6202
6203 p = cob_strdup (val);
6204
6205 n = 0;
6206 token = strtok (p, " ");
6207 for (; token; token = strtok (NULL, " ")) {
6208 int toklen = (int)strlen (token) + 1;
6209 if ((n + toklen) > CB_IVAL_SIZE) {
6210 if (n) {
6211 if (format == 2 || format == 3)
6212 printf ("\n %*.*s", CB_IMSG_SIZE + 3,
6213 CB_IMSG_SIZE + 3, " ");
6214 else
6215 printf ("\n%*.*s", CB_IMSG_SIZE + 3, CB_IMSG_SIZE + 3, " ");
6216 }
6217 n = 0;
6218 }
6219 printf ("%s%s", (n ? " " : ""), token);
6220 n += toklen;
6221 }
6222 putchar ('\n');
6223 cob_free (p);
6224 }
6225
6226 }
6227
6228 /*
6229 Expand a string with environment variable in it.
6230 Return malloced string.
6231 */
6232 char *
6233 cob_expand_env_string (char *strval)
6234 {
6235 unsigned int i;
6236 unsigned int j = 0;
6237 unsigned int k = 0;
6238 size_t envlen = 1280;
6239 char *env;
6240 char *str;
6241 char ename[128] = { '\0' };
6242 char *penv;
6243
6244 env = cob_malloc (envlen);
6245 for (k = 0; strval[k] != 0; k++) {
6246 /* String almost full?; Expand it */
6247 if (j >= envlen - 128) {
6248 env = cob_realloc (env, envlen, envlen + 256);
6249 envlen += 256;
6250 }
6251
6252 /* ${envname:default} */
6253 if (strval[k] == '$' && strval[k + 1] == '{') {
6254 k += 2;
6255 for (i = 0; strval[k] != '}'
6256 && strval[k] != 0
6257 && strval[k] != ':'; k++) {
6258 ename[i++] = strval[k];
6259 }
6260 ename[i++] = 0;
6261 penv = getenv (ename);
6262 if (penv == NULL) {
6263 /* Copy 'default' value */
6264 if (strval[k] == ':') {
6265 k++;
6266 /* ${name:-default} */
6267 if (strval[k] == '-') {
6268 k++;
6269 }
6270 while (strval[k] != '}' && strval[k] != 0) {
6271 if (j >= envlen - 50) {
6272 env = cob_realloc (env, envlen, envlen + 128);
6273 envlen += 128;
6274 }
6275 env[j++] = strval[k++];
6276 }
6277 } else if (strcmp (ename, "COB_CONFIG_DIR") == 0) {
6278 penv = (char *)COB_CONFIG_DIR;
6279 } else if (strcmp (ename, "COB_COPY_DIR") == 0) {
6280 penv = (char *)COB_COPY_DIR;
6281 }
6282 }
6283 if (penv != NULL) {
6284 if ((strlen (penv) + j) > (envlen - 128)) {
6285 env = cob_realloc (env, envlen, strlen (penv) + 256);
6286 envlen = strlen (penv) + 256;
6287 }
6288 j += sprintf (&env[j], "%s", penv);
6289 penv = NULL;
6290 }
6291 while (strval[k] != '}' && strval[k] != 0) {
6292 k++;
6293 }
6294 if (strval[k] == '}') {
6295 k++;
6296 }
6297 k--;
6298 } else if (strval[k] == '$'
6299 && strval[k+1] == '$') { /* Replace $$ with process-id */
6300 j += sprintf(&env[j],"%d",cob_sys_getpid());
6301 k++;
6302 } else if (!isspace ((unsigned char)strval[k])) {
6303 env[j++] = strval[k];
6304 } else {
6305 env[j++] = ' ';
6306 }
6307 }
6308
6309 env[j] = '\0';
6310 str = cob_strdup (env);
6311 cob_free (env);
6312
6313 return str;
6314 }
6315
6316 /* Store 'integer' value in field for correct length (computed with sizeof (fieldtype)) */
6317 static void
6318 set_value (char *data, int len, cob_s64_t val)
6319 {
6320 /* keep in order of occurrence in data types, last nanoseconds for startup... */
6321 if (len == sizeof (int)) {
6322 *(int *)data = (int)val;
6323 } else if (len == sizeof (short)) {
6324 *(short *)data = (short)val;
6325 } else if (len == sizeof (cob_s64_t)) {
6326 *(cob_s64_t *)data = val;
6327 } else {
6328 *data = (char)val;
6329 }
6330 }
6331
6332 /* Get 'integer' value from field */
6333 static cob_s64_t
6334 get_value (char *data, int len)
6335 {
6336 if (len == sizeof (int)) {
6337 return *(int *)data;
6338 } else if (len == sizeof (short)) {
6339 return *(short *)data;
6340 } else if (len == sizeof (cob_s64_t)) {
6341 return *(cob_s64_t *)data;
6342 } else {
6343 return *data;
6344 }
6345 }
6346
6347 static int
6348 translate_boolean_to_int (const char* ptr)
6349 {
6350 if (ptr == NULL || *ptr == 0) {
6351 return 2;
6352 }
6353
6354 if (*(ptr + 1) == 0 && isdigit ((unsigned char)*ptr)) {
6355 return atoi (ptr); /* 0 or 1 */
6356 } else
6357 if (strcasecmp (ptr, "true") == 0
6358 || strcasecmp (ptr, "t") == 0
6359 || strcasecmp (ptr, "on") == 0
6360 || strcasecmp (ptr, "yes") == 0
6361 || strcasecmp (ptr, "y") == 0) {
6362 return 1; /* True value */
6363 } else
6364 if (strcasecmp (ptr, "false") == 0
6365 || strcasecmp (ptr, "f") == 0
6366 || strcasecmp (ptr, "off") == 0
6367 || strcasecmp (ptr, "no") == 0
6368 || strcasecmp (ptr, "n") == 0) {
6369 return 0; /* False value */
6370 }
6371 return 2;
6372 }
6373
6374 /* Set runtime setting with given value */
6375 static int /* returns 1 if any error, else 0 */
6376 set_config_val (char *value, int pos)
6377 {
6378 char *data;
6379 char *ptr = value, *str;
6380 cob_s64_t numval = 0;
6381 int i, data_type, data_len, slen;
6382 size_t data_loc;
6383
6384 data_type = gc_conf[pos].data_type;
6385 data_loc = gc_conf[pos].data_loc;
6386 data_len = gc_conf[pos].data_len;
6387
6388 data = ((char *)cobsetptr) + data_loc;
6389
6390 if (gc_conf[pos].enums) { /* Translate 'word' into alternate 'value' */
6391
6392 for (i = 0; gc_conf[pos].enums[i].match != NULL; i++) {
6393 if (strcasecmp (value, gc_conf[pos].enums[i].match) == 0) {
6394 ptr = value = (char *)gc_conf[pos].enums[i].value;
6395 break;
6396 }
6397 if ((data_type & ENV_ENUMVAL) && strcasecmp (value, gc_conf[pos].enums[i].value) == 0) {
6398 break;
6399 }
6400 }
6401 if ((data_type & ENV_ENUM || data_type & ENV_ENUMVAL) /* Must be one of the 'enum' values */
6402 && gc_conf[pos].enums[i].match == NULL) {
6403 conf_runtime_error_value (ptr, pos);
6404 fprintf (stderr, _("should be one of the following values: %s"), "");
6405 for (i = 0; gc_conf[pos].enums[i].match != NULL; i++) {
6406 if (i != 0) {
6407 putc (',', stderr);
6408 putc (' ', stderr);
6409 }
6410 fprintf (stderr, "%s", (char *)gc_conf[pos].enums[i].match);
6411 if (data_type & ENV_ENUMVAL) {
6412 fprintf (stderr, "(%s)", (char *)gc_conf[pos].enums[i].value);
6413 }
6414 }
6415 putc ('\n', stderr);
6416 fflush (stderr);
6417 return 1;
6418 }
6419 }
6420
6421 if ((data_type & ENV_UINT) /* Integer data, unsigned */
6422 || (data_type & ENV_SINT) /* Integer data, signed */
6423 || (data_type & ENV_SIZE) ) { /* Size: integer with K, M, G */
6424 char sign = 0;
6425 for (; *ptr == ' '; ptr++); /* skip leading space */
6426 if (*ptr == '-'
6427 || *ptr == '+') {
6428 if ((data_type & ENV_SINT) == 0) {
6429 conf_runtime_error_value (ptr, pos);
6430 conf_runtime_error (1, _("should be unsigned")); // cob_runtime_warning
6431 return 1;
6432 }
6433 sign = *ptr;
6434 ptr++;
6435 }
6436 if (!isdigit ((unsigned char)*ptr)) {
6437 conf_runtime_error_value (ptr, pos);
6438 conf_runtime_error (1, _("should be numeric"));
6439 return 1;
6440 }
6441 for (; *ptr != 0 && (isdigit ((unsigned char)*ptr)); ptr++) {
6442 numval = (numval * 10) + ((cob_s64_t)*ptr - '0');
6443 }
6444 if (sign != 0
6445 && ( *ptr == '-'
6446 || *ptr == '+')) {
6447 if ((data_type & ENV_SINT) == 0) {
6448 conf_runtime_error_value (ptr, pos);
6449 conf_runtime_error (1, _("should be unsigned"));
6450 return 1;
6451 }
6452 sign = *ptr;
6453 ptr++;
6454 }
6455 if ((data_type & ENV_SIZE) /* Size: any K, M, G */
6456 && *ptr != 0) {
6457 switch (toupper ((unsigned char)*ptr)) {
6458 case 'K':
6459 numval = numval * 1024;
6460 ptr++;
6461 break;
6462 case 'M':
6463 if (numval < 4001) {
6464 numval = numval * 1024 * 1024;
6465 } else {
6466 /* use max. guaranteed value for unsigned long
6467 to raise a warning as max value is limit to one less */
6468 numval = 4294967295;
6469 }
6470 ptr++;
6471 break;
6472 case 'G':
6473 if (numval < 4) {
6474 numval = numval * 1024 * 1024 * 1024;
6475 } else {
6476 /* use max. guaranteed value for unsigned long
6477 to raise a warning as max value is limit to one less */
6478 numval = 4294967295;
6479 }
6480 ptr++;
6481 break;
6482 }
6483 }
6484 for (; *ptr == ' '; ptr++); /* skip trailing space */
6485 if (*ptr != 0) {
6486 conf_runtime_error_value (ptr, pos);
6487 conf_runtime_error (1, _("should be numeric"));
6488 return 1;
6489 }
6490 if (sign == '-') {
6491 numval = -numval;
6492 }
6493 if (gc_conf[pos].min_value > 0
6494 && numval < gc_conf[pos].min_value) {
6495 conf_runtime_error_value (value, pos);
6496 conf_runtime_error (1, _("minimum value: %lu"), gc_conf[pos].min_value);
6497 return 1;
6498 }
6499 if (gc_conf[pos].max_value > 0
6500 && numval > gc_conf[pos].max_value) {
6501 conf_runtime_error_value (value, pos);
6502 conf_runtime_error (1, _("maximum value: %lu"), gc_conf[pos].max_value);
6503 return 1;
6504 }
6505 set_value (data, data_len, numval);
6506 if (strcmp (gc_conf[pos].env_name, "COB_MOUSE_FLAGS") == 0) {
6507 cob_settings_screenio ();
6508 }
6509
6510 } else if ((data_type & ENV_BOOL)) { /* Boolean: Yes/No, True/False,... */
6511 numval = translate_boolean_to_int (ptr);
6512
6513 if (numval != 1
6514 && numval != 0) {
6515 conf_runtime_error_value (ptr, pos);
6516 conf_runtime_error (1, _("should be one of the following values: %s"), "true, false");
6517 return 1;
6518 }
6519 if ((data_type & ENV_NOT)) { /* Negate logic for actual setting */
6520 numval = !numval;
6521 }
6522 set_value (data, data_len, numval);
6523 if ((data_type & ENV_RESETS)) { /* Additional setup needed */
6524 if (strcmp(gc_conf[pos].env_name, "COB_SET_DEBUG") == 0) {
6525 /* Copy variables from settings (internal) to global structure, each time */
6526 cobglobptr->cob_debugging_mode = cobsetptr->cob_debugging_mode;
6527 }
6528 }
6529 if (strcmp (gc_conf[pos].env_name, "COB_INSERT_MODE") == 0) {
6530 cob_settings_screenio ();
6531 }
6532
6533 } else if ((data_type & ENV_FILE)
6534 || (data_type & ENV_PATH)) { /* Path (environment expanded) to be stored as a string */
6535 memcpy (&str, data, sizeof (char *));
6536 if (str != NULL) {
6537 cob_free ((void *)str);
6538 }
6539 str = cob_expand_env_string (value);
6540 if ((data_type & ENV_FILE)
6541 && strchr (str, PATHSEP_CHAR) != NULL) {
6542 conf_runtime_error_value (value, pos);
6543 conf_runtime_error (1, _("should not contain '%c'"), PATHSEP_CHAR);
6544 cob_free (str);
6545 return 1;
6546 }
6547 memcpy (data, &str, sizeof (char *));
6548 if (data_loc == offsetof (cob_settings, cob_preload_str)) {
6549 cobsetptr->cob_preload_str_set = cob_strdup(str);
6550 }
6551
6552 /* call internal routines that do post-processing */
6553 if (strcmp (gc_conf[pos].env_name, "COB_TRACE_FILE") == 0
6554 && cobsetptr->cob_trace_file != NULL) {
6555 cob_new_trace_file ();
6556 }
6557
6558 } else if (data_type & ENV_STR) { /* String (environment expanded) */
6559 memcpy (&str, data, sizeof (char *));
6560 if (str != NULL) {
6561 cob_free ((void *)str);
6562 }
6563 str = cob_expand_env_string (value);
6564 memcpy (data, &str, sizeof (char *));
6565 if (data_loc == offsetof (cob_settings, cob_preload_str)) {
6566 cobsetptr->cob_preload_str_set = cob_strdup(str);
6567 }
6568
6569 /* call internal routines that do post-processing */
6570 if (strcmp (gc_conf[pos].env_name, "COB_CURRENT_DATE") == 0) {
6571 check_current_date ();
6572 }
6573
6574 } else if ((data_type & ENV_CHAR)) { /* 'char' field inline */
6575 memset (data, 0, data_len);
6576 slen = (int)strlen (value);
6577 if (slen > data_len) {
6578 slen = data_len;
6579 }
6580 memcpy (data, value, slen);
6581 }
6582 return 0;
6583 }
6584
6585 /* Set runtime setting by name with given value */
6586 static int /* returns 1 if any error, else 0 */
6587 set_config_val_by_name (char *value, const char *name, const char *func)
6588 {
6589 int i;
6590 int ret = 1;
6591
6592 for (i = 0; i < NUM_CONFIG; i++) {
6593 if (!strcmp (gc_conf[i].conf_name, name)) {
6594 ret = set_config_val (value, i);
6595 if (func) {
6596 gc_conf[i].data_type |= STS_FNCSET;
6597 gc_conf[i].set_by = FUNC_NAME_IN_DEFAULT;
6598 gc_conf[i].default_val = func;
6599 }
6600 break;
6601 }
6602 }
6603 return ret;
6604 }
6605
6606 /* Return setting value as a 'string' */
6607 static char *
6608 get_config_val (char *value, int pos, char *orgvalue)
6609 {
6610 char *data;
6611 char *str;
6612 double dval;
6613 cob_s64_t numval;
6614 int i, data_type, data_len;
6615 size_t data_loc;
6616
6617 data_type = gc_conf[pos].data_type;
6618 data_loc = gc_conf[pos].data_loc;
6619 data_len = gc_conf[pos].data_len;
6620
6621 data = ((char *)cobsetptr) + data_loc;
6622
6623 if (min_conf_length == 0) {
6624 not_set = _("not set");
6625 min_conf_length = (char) strlen (not_set) + 1;
6626 if (min_conf_length < 6) {
6627 min_conf_length = 6;
6628 } else if (min_conf_length > 15) {
6629 min_conf_length = 15;
6630 }
6631 }
6632
6633 strcpy (value, _("unknown"));
6634 orgvalue[0] = 0;
6635 if (data_type & ENV_UINT) { /* Integer data, unsigned */
6636 numval = get_value (data, data_len);
6637 sprintf (value, CB_FMT_LLU, numval);
6638
6639 } else if (data_type & ENV_SINT) { /* Integer data, signed */
6640 numval = get_value (data, data_len);
6641 sprintf (value, CB_FMT_LLD, numval);
6642
6643 } else if ((data_type & ENV_SIZE)) { /* Size: integer with K, M, G */
6644 numval = get_value (data, data_len);
6645 dval = (double) numval;
6646 if (numval > (1024 * 1024 * 1024)) {
6647 if ((numval % (1024 * 1024 * 1024)) == 0) {
6648 sprintf (value, CB_FMT_LLD" GB", numval / (1024 * 1024 * 1024));
6649 } else {
6650 sprintf (value, "%.2f GB", dval / (1024.0 * 1024.0 * 1024.0));
6651 }
6652 } else if (numval > (1024 * 1024)) {
6653 if ((numval % (1024 * 1024)) == 0) {
6654 sprintf (value, CB_FMT_LLD" MB", numval / (1024 * 1024));
6655 } else {
6656 sprintf (value, "%.2f MB", dval / (1024.0 * 1024.0));
6657 }
6658 } else if (numval > 1024) {
6659 if ((numval % 1024) == 0) {
6660 sprintf (value, CB_FMT_LLD" KB", numval / 1024);
6661 } else {
6662 sprintf (value, "%.2f KB", dval / 1024.0);
6663 }
6664 } else {
6665 sprintf (value, CB_FMT_LLD, numval);
6666 }
6667
6668 } else if ((data_type & ENV_BOOL)) { /* Boolean: Yes/No, True/False,... */
6669 numval = get_value (data, data_len);
6670 if ((data_type & ENV_NOT)) {
6671 numval = !numval;
6672 }
6673 if (numval) {
6674 strcpy (value, _("yes"));
6675 } else {
6676 strcpy (value, _("no"));
6677 }
6678
6679 /* TO-DO: Consolidate copy-and-pasted code! */
6680 } else if ((data_type & ENV_STR)) { /* String stored as a string */
6681 memcpy (&str, data, sizeof (char *));
6682 if (data_loc == offsetof (cob_settings, cob_display_print_filename)
6683 && cobsetptr->cob_display_print_file) {
6684 snprintf (value, COB_MEDIUM_MAX, _("set by %s"), "cob_set_runtime_option");
6685 } else if (data_loc == offsetof (cob_settings, cob_display_punch_filename)
6686 && cobsetptr->cob_display_punch_file) {
6687 snprintf (value, COB_MEDIUM_MAX, _("set by %s"), "cob_set_runtime_option");
6688 } else if(data_loc == offsetof (cob_settings, cob_trace_filename)
6689 && cobsetptr->external_trace_file) {
6690 snprintf (value, COB_MEDIUM_MAX, _("set by %s"), "cob_set_runtime_option");
6691 } else if (str == NULL) {
6692 snprintf (value, COB_MEDIUM_MAX, _("not set"));
6693 } else {
6694 snprintf (value, COB_MEDIUM_MAX, "'%s'", str);
6695 }
6696
6697 } else if ((data_type & ENV_FILE)) { /* File/path stored as a string */
6698 memcpy (&str, data, sizeof (char *));
6699 /* TODO: add special cases here on merging rw-branch */
6700 if (str == NULL) {
6701 snprintf (value, COB_MEDIUM_MAX, _("not set"));
6702 } else {
6703 snprintf (value, COB_MEDIUM_MAX, "%s", str);
6704 }
6705
6706 } else if ((data_type & ENV_PATH)) { /* Path stored as a string */
6707 memcpy (&str, data, sizeof (char *));
6708 if (str == NULL) {
6709 snprintf (value, COB_MEDIUM_MAX, _("not set"));
6710 } else {
6711 snprintf (value, COB_MEDIUM_MAX, "%s", str);
6712 }
6713
6714 } else if ((data_type & ENV_CHAR)) { /* 'char' field inline */
6715 if (*(char *)data == 0) {
6716 strcpy (value, "Nul");
6717 } else if (isprint (*(unsigned char *)data)) {
6718 sprintf (value, "'%s'", (char *)data);
6719 } else {
6720 sprintf (value, "0x%02X", *(char *)data);
6721 }
6722 }
6723 value[COB_MEDIUM_MAX] = 0; /* fix warning */
6724
6725 if (gc_conf[pos].enums) { /* Translate 'word' into alternate 'value' */
6726 for (i = 0; gc_conf[pos].enums[i].match != NULL; i++) {
6727 if (strcasecmp (value, gc_conf[pos].enums[i].value) == 0) {
6728 if (strcmp (value, "0") != 0
6729 && strcmp (value, gc_conf[pos].default_val) != 0) {
6730 strcpy (orgvalue, value);
6731 }
6732 strcpy (value, gc_conf[pos].enums[i].match);
6733 if (strcmp (value, "not set") != 0) {
6734 snprintf (value, COB_MEDIUM_MAX, _("not set"));
6735 value[COB_MEDIUM_MAX] = 0; /* fix warning */
6736 }
6737 break;
6738 }
6739 }
6740 }
6741 return value;
6742 }
6743
6744 static int
6745 cb_lookup_config (char *keyword)
6746 {
6747 int i;
6748 for (i = 0; i < NUM_CONFIG; i++) { /* Set value from config file */
6749 if (gc_conf[i].conf_name
6750 && strcasecmp (keyword, gc_conf[i].conf_name) == 0) { /* Look for config file name */
6751 break;
6752 }
6753 if (gc_conf[i].env_name
6754 && strcasecmp (keyword, gc_conf[i].env_name) == 0) { /* Catch using env var name */
6755 break;
6756 }
6757 }
6758 return i;
6759 }
6760
6761 static int
6762 cb_config_entry (char *buf, int line)
6763 {
6764 int i, j, k, old_type;
6765 void *data;
6766 char *str, qt;
6767 char keyword[COB_MINI_BUFF], value[COB_SMALL_BUFF];
6768
6769 cob_source_line = line;
6770
6771 for (j= (int)strlen (buf); buf[j-1] == '\r' || buf[j-1] == '\n'; ) /* Remove CR LF */
6772 buf[--j] = 0;
6773
6774 for (i = 0; isspace ((unsigned char)buf[i]); i++);
6775
6776 for (j = 0; buf[i] != 0 && buf[i] != ':' && !isspace ((unsigned char)buf[i]) && buf[i] != '=' && buf[i] != '#'; )
6777 keyword[j++] = buf[i++];
6778 keyword[j] = 0;
6779
6780 while (buf[i] != 0 && (isspace ((unsigned char)buf[i]) || buf[i] == ':' || buf[i] == '=')) i++;
6781 if (buf[i] == '"'
6782 || buf[i] == '\'') {
6783 qt = buf[i++];
6784 for (j = 0; buf[i] != qt && buf[i] != 0; )
6785 value[j++] = buf[i++];
6786 } else {
6787 for (j = 0; !isspace ((unsigned char)buf[i]) && buf[i] != '#' && buf[i] != 0; )
6788 value[j++] = buf[i++];
6789 }
6790
6791 value[j] = 0;
6792 if (strcasecmp (keyword, "reset") != 0
6793 && strcasecmp (keyword, "include") != 0
6794 && strcasecmp (keyword, "includeif") != 0
6795 && strcasecmp (keyword, "setenv") != 0
6796 && strcasecmp (keyword, "unsetenv") != 0) {
6797 i = cb_lookup_config (keyword);
6798
6799 if (i >= NUM_CONFIG) {
6800 conf_runtime_error (1, _("unknown configuration tag '%s'"), keyword);
6801 return -1;
6802 }
6803 }
6804 if (strcmp (value, "") == 0) {
6805 if (strcasecmp (keyword, "include") != 0
6806 && strcasecmp (keyword, "includeif")) {
6807 conf_runtime_error(1, _("WARNING - '%s' without a value - ignored!"), keyword);
6808 return 2;
6809 } else {
6810 conf_runtime_error (1, _("'%s' without a value!"), keyword);
6811 return -1;
6812 }
6813 }
6814
6815 if (strcasecmp (keyword, "setenv") == 0 ) {
6816 char value2[COB_SMALL_BUFF];
6817 /* collect additional value and push into environment */
6818 strcpy (value2, "");
6819 /* check for := in value 2 and split, if necessary */
6820 k = 0; while (value[k] != '=' && value[k] != ':' && value[k] != '"' && value[k] != '\'' && value[k] != 0) k++;
6821 if (value[k] == '=' || value[k] == ':') {
6822 i = i - (int)strlen (value + k);
6823 value[k] = 0;
6824 }
6825 while (isspace ((unsigned char)buf[i]) || buf[i] == ':' || buf[i] == '=') i++;
6826 if (buf[i] == '"'
6827 || buf[i] == '\'') {
6828 qt = buf[i++];
6829 for (j = 0; buf[i] != qt && buf[i] != 0; )
6830 value2[j++] = buf[i++];
6831 } else {
6832 for (j = 0; !isspace ((unsigned char)buf[i]) && buf[i] != '#' && buf[i] != 0; )
6833 value2[j++] = buf[i++];
6834 }
6835 value2[j] = 0;
6836 if (strcmp (value2, "") == 0) {
6837 conf_runtime_error (1, _("WARNING - '%s %s' without a value - ignored!"), keyword, value);
6838 return 2;
6839 }
6840 /* check additional value for inline env vars ${varname:-default} */
6841 str = cob_expand_env_string (value2);
6842
6843 (void)cob_setenv (value, str, 1);
6844 cob_free (str);
6845 for (i = 0; i < NUM_CONFIG; i++) { /* Set value from config file */
6846 if (gc_conf[i].env_name
6847 && strcasecmp (value, gc_conf[i].env_name) == 0) {/* no longer cleared by runtime.cfg */
6848 gc_conf[i].data_type &= ~STS_ENVCLR;
6849 break;
6850 }
6851 }
6852 return 0;
6853 }
6854
6855 if (strcasecmp (keyword, "unsetenv") == 0) {
6856 if ((getenv (value)) != NULL ) {
6857 for (i = 0; i < NUM_CONFIG; i++) { /* Set value from config file */
6858 if (gc_conf[i].env_name
6859 && strcasecmp (value, gc_conf[i].env_name) == 0) { /* Catch using env var name */
6860 gc_conf[i].data_type |= STS_ENVCLR;
6861 break;
6862 }
6863 }
6864 (void)cob_unsetenv (value);
6865 }
6866 return 0;
6867 }
6868
6869 if (strcasecmp (keyword, "include") == 0 ||
6870 strcasecmp (keyword, "includeif") == 0) {
6871 str = cob_expand_env_string (value);
6872 strcpy (buf, str);
6873 cob_free (str);
6874 if (strcasecmp (keyword, "include") == 0) {
6875 return 1;
6876 } else {
6877 return 3;
6878 }
6879 }
6880
6881 if (strcasecmp (keyword, "reset") == 0) {
6882 i = cb_lookup_config (value);
6883 if (i >= NUM_CONFIG) {
6884 conf_runtime_error (1, _("unknown configuration tag '%s'"), value);
6885 return -1;
6886 }
6887 gc_conf[i].data_type &= ~(STS_ENVSET | STS_CNFSET | STS_ENVCLR); /* Clear status */
6888 gc_conf[i].data_type |= STS_RESET;
6889 gc_conf[i].set_by = 0;
6890 gc_conf[i].config_num = cobsetptr->cob_config_cur - 1;
6891 if (gc_conf[i].default_val) {
6892 set_config_val ((char *)gc_conf[i].default_val, i);
6893 } else if ((gc_conf[i].data_type & ENV_STR)
6894 || (gc_conf[i].data_type & ENV_FILE)
6895 || (gc_conf[i].data_type & ENV_PATH)) { /* String/Path stored as a string */
6896 data = (void *) ((char *)cobsetptr + gc_conf[i].data_loc);
6897 memcpy (&str, data, sizeof (char *));
6898 if (str != NULL) {
6899 cob_free ((void *)str);
6900 }
6901 str = NULL;
6902 memcpy (data, &str, sizeof (char *)); /* Reset pointer to NULL */
6903 } else {
6904 set_config_val ((char *)"0", i);
6905 }
6906 return 0;
6907 }
6908
6909 i = cb_lookup_config (keyword);
6910
6911 if (i >= NUM_CONFIG) {
6912 conf_runtime_error (1, _("unknown configuration tag '%s'"), keyword);
6913 return -1;
6914 }
6915
6916 old_type = gc_conf[i].data_type;
6917 gc_conf[i].data_type |= STS_CNFSET;
6918 if (!set_config_val (value, i)) {
6919 gc_conf[i].data_type &= ~STS_RESET;
6920 gc_conf[i].config_num = cobsetptr->cob_config_cur - 1;
6921
6922 if (gc_conf[i].env_group == GRP_HIDE) {
6923 for (j = 0; j < NUM_CONFIG; j++) { /* Any alias present? */
6924 if (j != i
6925 && gc_conf[i].data_loc == gc_conf[j].data_loc) {
6926 gc_conf[j].data_type |= STS_CNFSET;
6927 gc_conf[j].data_type &= ~STS_RESET;
6928 gc_conf[j].config_num = gc_conf[i].config_num;
6929 gc_conf[j].set_by = i;
6930 }
6931 }
6932 }
6933 } else {
6934 gc_conf[i].data_type = old_type;
6935 }
6936 return 0;
6937 }
6938
6939 static int
6940 cob_load_config_file (const char *config_file, int isoptional)
6941 {
6942 char buff[COB_FILE_BUFF-10], filename[COB_FILE_BUFF];
6943 char *penv;
6944 int sub_ret, ret;
6945 unsigned int i;
6946 int line;
6947 FILE *conf_fd;
6948
6949 for (i = 0; config_file[i] != 0 && config_file[i] != SLASH_CHAR; i++);
6950 if (config_file[i] == 0) { /* Just a name, No directory */
6951 if (access (config_file, F_OK) != 0) { /* and file does not exist */
6952 /* check for path of previous configuration file (for includes) */
6953 filename[0] = 0;
6954 if (cobsetptr->cob_config_cur != 0) {
6955 size_t size;
6956 strncpy (buff,
6957 cobsetptr->cob_config_file[cobsetptr->cob_config_cur - 1],
6958 (size_t)COB_FILE_MAX-10);
6959 size = strlen (buff);
6960 if (size != 0 && buff[size] == SLASH_CHAR) buff[--size] = 0;
6961 if (size != 0) {
6962 snprintf (filename, (size_t)COB_FILE_MAX, "%s%c%s", buff, SLASH_CHAR,
6963 config_file);
6964 if (access (filename, F_OK) == 0) { /* and prefixed file exist */
6965 config_file = filename; /* Prefix last directory */
6966 } else {
6967 filename[0] = 0;
6968 }
6969 }
6970 }
6971 if (filename[0] == 0) {
6972 /* check for COB_CONFIG_DIR (use default if not in environment) */
6973 penv = getenv ("COB_CONFIG_DIR");
6974 if (penv != NULL) {
6975 snprintf (filename, (size_t)COB_FILE_MAX, "%s%c%s",
6976 penv, SLASH_CHAR, config_file);
6977 } else {
6978 snprintf (filename, (size_t)COB_FILE_MAX, "%s%c%s",
6979 COB_CONFIG_DIR, SLASH_CHAR, config_file);
6980 }
6981 if (access (filename, F_OK) == 0) { /* and prefixed file exist */
6982 config_file = filename; /* Prefix COB_CONFIG_DIR */
6983 }
6984 }
6985 }
6986 }
6987
6988 cob_source_file = config_file;
6989
6990 /* check for recursion */
6991 for (i = 0; i < cobsetptr->cob_config_num; i++) {
6992 if (strcmp (cobsetptr->cob_config_file[i], config_file) == 0) {
6993 cob_source_line = 0;
6994 conf_runtime_error (1, _("recursive inclusion"));
6995 return -2;
6996 }
6997 }
6998
6999 /* Open the configuration file */
7000 conf_fd = fopen (config_file, "r");
7001 if (conf_fd == NULL && !isoptional) {
7002 cob_source_line = 0;
7003 conf_runtime_error (1, cob_get_strerror ());
7004 if (cobsetptr->cob_config_file) {
7005 cob_source_file = cobsetptr->cob_config_file[cobsetptr->cob_config_num-1];
7006 }
7007 return -1;
7008 }
7009 if (conf_fd != NULL) {
7010 if (cobsetptr->cob_config_file == NULL) {
7011 cobsetptr->cob_config_file = cob_malloc (sizeof (char *));
7012 } else {
7013 const size_t old_size = sizeof (char *) * cobsetptr->cob_config_num;
7014 const size_t new_size = sizeof (char *) * (cobsetptr->cob_config_num + 1);
7015 cobsetptr->cob_config_file = cob_realloc (cobsetptr->cob_config_file, old_size, new_size);
7016 }
7017 cobsetptr->cob_config_file[cobsetptr->cob_config_num++] = cob_strdup (config_file); /* Save config file name */
7018 cobsetptr->cob_config_cur = cobsetptr->cob_config_num;
7019 }
7020
7021
7022 /* Read the configuration file */
7023 ret = 0;
7024 line = 0;
7025 while ((conf_fd != NULL)
7026 && (fgets (buff, COB_SMALL_BUFF, conf_fd) != NULL) ) {
7027 line++;
7028 for (i = 0; isspace ((unsigned char)buff[i]); i++);
7029 if (buff[i] == 0
7030 || buff[i] == '#'
7031 || buff[i] == '\r'
7032 || buff[i] == '\n')
7033 continue; /* Skip comments and blank lines */
7034
7035 /* Evaluate config line */
7036 sub_ret = cb_config_entry (buff, line);
7037
7038 /* Include another configuration file */
7039 if (sub_ret == 1 || sub_ret == 3) {
7040 cob_source_line = line;
7041 sub_ret = cob_load_config_file (buff, sub_ret == 3);
7042 cob_source_file = config_file;
7043 if (sub_ret < 0) {
7044 ret = -1;
7045 cob_source_line = line;
7046 conf_runtime_error (1, _("configuration file was included here"));
7047 break;
7048 }
7049 }
7050 if (sub_ret < ret) ret = sub_ret;
7051 }
7052 if (conf_fd) {
7053 fclose (conf_fd);
7054 cobsetptr->cob_config_cur--;
7055 }
7056 cob_source_file = NULL;
7057 conf_fd = NULL;
7058
7059 return ret;
7060 }
7061
7062 /*
7063 * Load the GnuCOBOL runtime configuration information
7064 */
7065 int
7066 cob_load_config (void)
7067 {
7068 char *env;
7069 char conf_file[COB_MEDIUM_BUFF];
7070 int is_optional = 1, sts, i, j;
7071
7072
7073 /* Get the name for the configuration file */
7074 if ((env = getenv ("COB_RUNTIME_CONFIG")) != NULL && env[0]) {
7075 strncpy (conf_file, env, (size_t)COB_MEDIUM_MAX);
7076 conf_file[COB_MEDIUM_MAX] = 0;
7077 is_optional = 0; /* If declared then it is NOT optional */
7078 if (strchr (conf_file, PATHSEP_CHAR) != NULL) {
7079 conf_runtime_error (0, _("invalid value '%s' for configuration tag '%s'"), conf_file, "COB_RUNTIME_CONFIG");
7080 conf_runtime_error (1, _("should not contain '%c'"), PATHSEP_CHAR);
7081 return -1;
7082 }
7083 } else {
7084 /* check for COB_CONFIG_DIR (use default if not in environment) */
7085 if ((env = getenv ("COB_CONFIG_DIR")) != NULL && env[0]) {
7086 snprintf (conf_file, (size_t)COB_MEDIUM_MAX, "%s%c%s", env, SLASH_CHAR, "runtime.cfg");
7087 } else {
7088 snprintf (conf_file, (size_t)COB_MEDIUM_MAX, "%s%c%s", COB_CONFIG_DIR, SLASH_CHAR, "runtime.cfg");
7089 }
7090 conf_file[COB_MEDIUM_MAX] = 0; /* fixing code analyser warning */
7091 is_optional = 1; /* If not present, then just use env vars */
7092 if (strchr (conf_file, PATHSEP_CHAR) != NULL) {
7093 conf_runtime_error (0, _("invalid value '%s' for configuration tag '%s'"), conf_file, "COB_CONFIG_DIR");
7094 conf_runtime_error (1, _("should not contain '%c'"), PATHSEP_CHAR);
7095 return -1;
7096 }
7097 }
7098
7099 sprintf (varseq_dflt, "%d", WITH_VARSEQ); /* Default comes from config.h */
7100 for (i = 0; i < NUM_CONFIG; i++) {
7101 gc_conf[i].data_type &= ~(STS_ENVSET | STS_CNFSET | STS_ENVCLR); /* Clear status */
7102 }
7103
7104 sts = cob_load_config_file (conf_file, is_optional);
7105 if (sts < 0) {
7106 return sts;
7107 }
7108 cob_rescan_env_vals (); /* Check for possible environment variables */
7109
7110 /* Set with default value if present and not set otherwise */
7111 for (i = 0; i < NUM_CONFIG; i++) {
7112 if (gc_conf[i].default_val
7113 && !(gc_conf[i].data_type & STS_CNFSET)
7114 && !(gc_conf[i].data_type & STS_ENVSET)) {
7115 for (j = 0; j < NUM_CONFIG; j++) { /* Any alias present? */
7116 if (j != i
7117 && gc_conf[i].data_loc == gc_conf[j].data_loc)
7118 break;
7119 }
7120 if (j < NUM_CONFIG) {
7121 if (!(gc_conf[j].data_type & STS_CNFSET)
7122 && !(gc_conf[j].data_type & STS_ENVSET)) { /* alias not defined? */
7123 set_config_val ((char *)gc_conf[i].default_val, i);
7124 }
7125 } else {
7126 set_config_val ((char *)gc_conf[i].default_val, i); /* Set default value */
7127 }
7128 }
7129 }
7130 check_current_date();
7131
7132 return 0;
7133 }
7134
7135 static void
7136 output_source_location (void)
7137 {
7138 if (cobglobptr && COB_MODULE_PTR
7139 && COB_MODULE_PTR->module_stmt != 0
7140 && COB_MODULE_PTR->module_sources) {
7141 fprintf (stderr, "%s:%u: ",
7142 COB_MODULE_PTR->module_sources
7143 [COB_GET_FILE_NUM(COB_MODULE_PTR->module_stmt)],
7144 COB_GET_LINE_NUM(COB_MODULE_PTR->module_stmt));
7145 } else {
7146 if (cob_source_file) {
7147 fprintf (stderr, "%s:", cob_source_file);
7148 if (!cob_source_line) {
7149 fputc (' ', stderr);
7150 }
7151 }
7152 if (cob_source_line) {
7153 fprintf (stderr, "%u:", cob_source_line);
7154 fputc (' ', stderr);
7155 }
7156 }
7157 }
7158
7159 /* output runtime warning for issues produced by external API functions */
7160 void
7161 cob_runtime_warning_external (const char *caller_name, const int cob_reference, const char *fmt, ...)
7162 {
7163 va_list args;
7164
7165 if (!cobsetptr->cob_display_warn) {
7166 return;
7167 }
7168 if (!(caller_name && *caller_name)) caller_name = "unknown caller";
7169
7170 /* Prefix */
7171 fprintf (stderr, "libcob: ");
7172 if (cob_reference) {
7173 output_source_location ();
7174 }
7175 fprintf (stderr, _("warning: "));
7176 fprintf (stderr, "%s: ", caller_name);
7177
7178 /* Body */
7179 va_start (args, fmt);
7180 vfprintf (stderr, fmt, args);
7181 va_end (args);
7182
7183 /* Postfix */
7184 putc ('\n', stderr);
7185 fflush (stderr);
7186 }
7187
7188 void
7189 cob_runtime_warning (const char *fmt, ...)
7190 {
7191 va_list args;
7192
7193 if (cobsetptr && !cobsetptr->cob_display_warn) {
7194 return;
7195 }
7196
7197 /* Prefix */
7198 fprintf (stderr, "libcob: ");
7199 output_source_location ();
7200 fprintf (stderr, _("warning: "));
7201
7202 /* Body */
7203 va_start (args, fmt);
7204 vfprintf (stderr, fmt, args);
7205 va_end (args);
7206
7207 /* Postfix */
7208 putc ('\n', stderr);
7209 fflush (stderr);
7210 }
7211
7212 void
7213 cob_runtime_hint (const char *fmt, ...)
7214 {
7215 va_list args;
7216
7217 /* Prefix */
7218 fprintf (stderr, "%s", _("note: "));
7219
7220 /* Body */
7221 va_start (args, fmt);
7222 vfprintf (stderr, fmt, args);
7223 va_end (args);
7224
7225 /* Postfix */
7226 putc ('\n', stderr);
7227 fflush (stderr);
7228 }
7229
7230 void
7231 cob_runtime_error (const char *fmt, ...)
7232 {
7233 struct handlerlist *h;
7234 char *p;
7235 va_list ap;
7236
7237 int more_error_procedures = 1;
7238
7239 #if 1 /* RXWRXW - Exit screen */
7240 /* Exit screen mode early */
7241 cob_exit_screen ();
7242 #endif
7243
7244 if (hdlrs != NULL && !active_error_handler && cobglobptr) {
7245
7246 const char *err_source_file;
7247 unsigned int err_source_line, err_module_statement = 0;
7248 cob_module_ptr err_module_pointer = NULL;
7249 int call_params = cobglobptr->cob_call_params;
7250
7251 if (runtime_err_str) {
7252 p = runtime_err_str;
7253 if (cob_source_file) {
7254 if (cob_source_line) {
7255 sprintf (runtime_err_str, "%s:%u: ",
7256 cob_source_file, cob_source_line);
7257 } else {
7258 sprintf (runtime_err_str, "%s: ",
7259 cob_source_file);
7260 }
7261 p = runtime_err_str + strlen (runtime_err_str);
7262 }
7263 va_start (ap, fmt);
7264 vsprintf (p, fmt, ap);
7265 va_end (ap);
7266 /* LCOV_EXCL_START */
7267 } else {
7268 runtime_err_str = (char *) "-";
7269 }
7270 /* LCOV_EXCL_STOP */
7271
7272 /* save error location */
7273 err_source_file = cob_source_file;
7274 err_source_line = cob_source_line;
7275 if (COB_MODULE_PTR) {
7276 err_module_pointer = COB_MODULE_PTR;
7277 err_module_statement = COB_MODULE_PTR->module_stmt;
7278 }
7279
7280 /* run registered error handlers */
7281 active_error_handler = 1;
7282 h = hdlrs;
7283 while (h != NULL) {
7284 int (*current_handler)(char *) = h->proc;
7285 struct handlerlist *hp = h;
7286
7287 h = h->next;
7288 cob_free (hp);
7289
7290 if (more_error_procedures) {
7291 /* fresh error buffer with guaranteed size */
7292 char local_err_str[COB_ERRBUF_SIZE] = "-";
7293 if (runtime_err_str != NULL) {
7294 memcpy (&local_err_str, runtime_err_str, COB_ERRBUF_SIZE);
7295 }
7296
7297 /* ensure that error handlers set their own locations */
7298 cob_source_file = NULL;
7299 cob_source_line = 0;
7300 cobglobptr->cob_call_params = 1;
7301
7302 more_error_procedures = current_handler (runtime_err_str);
7303 }
7304 }
7305 /* LCOV_EXCL_START */
7306 if (runtime_err_str[0] == '-' && runtime_err_str[1] == 0) {
7307 runtime_err_str = NULL;
7308 }
7309 /* LCOV_EXCL_STOP */
7310 hdlrs = NULL;
7311 active_error_handler = 0;
7312
7313 /* restore error location */
7314 cob_source_file = err_source_file;
7315 cob_source_line = err_source_line;
7316 COB_MODULE_PTR = err_module_pointer;
7317 if (COB_MODULE_PTR) {
7318 COB_MODULE_PTR->module_stmt = err_module_statement;
7319 }
7320 cobglobptr->cob_call_params = call_params;
7321 }
7322
7323 /* Prefix */
7324 if (more_error_procedures) {
7325 fputs ("libcob: ", stderr);
7326 if (cob_source_file) {
7327 fprintf (stderr, "%s:", cob_source_file);
7328 if (cob_source_line) {
7329 fprintf (stderr, "%u:", cob_source_line);
7330 }
7331 fputc (' ', stderr);
7332 }
7333 fprintf (stderr, "%s: ", _("error"));
7334
7335 /* Body */
7336 va_start (ap, fmt);
7337 vfprintf (stderr, fmt, ap);
7338 va_end (ap);
7339
7340 /* Postfix */
7341 fputc ('\n', stderr);
7342 fflush (stderr);
7343 }
7344
7345 /* setup reason for optional module dump */
7346 if (cob_initialized && abort_reason[0] == 0) {
7347 #if 0 /* Is there a use in this message ?*/
7348 fprintf (stderr, "\n");
7349 fprintf (stderr, _("abnormal termination - file contents may be incorrect"));
7350 #endif
7351 va_start (ap, fmt);
7352 vsnprintf (abort_reason, COB_MINI_BUFF, fmt, ap);
7353 va_end (ap);
7354 }
7355 }
7356
7357 void
7358 cob_fatal_error (const enum cob_fatal_error fatal_error)
7359 {
7360 const char *msg;
7361 unsigned char *file_status;
7362 char *err_cause;
7363 int status;
7364 #ifdef _WIN32
7365 char *p;
7366 #endif
7367
7368 switch (fatal_error) {
7369 #if 0 /* Currently not in use, should enter unknown error */
7370 case COB_FERROR_NONE:
7371 break;
7372 #endif
7373 /* Note: can be simply tested; therefore no exclusion */
7374 case COB_FERROR_CANCEL:
7375 cob_runtime_error (_("attempt to CANCEL active program"));
7376 break;
7377 /* Note: can be simply tested; therefore no exclusion */
7378 case COB_FERROR_INITIALIZED:
7379 #ifdef _WIN32
7380 /* cob_unix_lf needs to be set before any error message is thrown,
7381 as they would have wrong line endings otherwise */
7382 p = getenv ("COB_UNIX_LF");
7383 if (p && (*p == 'Y' || *p == 'y' ||
7384 *p == 'T' || *p == 't' ||
7385 *p == '1')) {
7386 (void)_setmode (_fileno (stdin), _O_BINARY);
7387 (void)_setmode (_fileno (stdout), _O_BINARY);
7388 (void)_setmode (_fileno (stderr), _O_BINARY);
7389 }
7390 #endif
7391 /* note: same message in call.c */
7392 cob_runtime_error (_("cob_init() has not been called"));
7393 break;
7394 /* LCOV_EXCL_START */
7395 case COB_FERROR_CODEGEN:
7396 cob_runtime_error ("codegen error"); /* not translated by intent */
7397 cob_runtime_error (_("Please report this!"));
7398 break;
7399 /* LCOV_EXCL_STOP */
7400 /* Note: can be simply tested; therefore no exclusion */
7401 case COB_FERROR_CHAINING:
7402 cob_runtime_error (_("CALL of program with CHAINING clause"));
7403 break;
7404 /* LCOV_EXCL_START */
7405 case COB_FERROR_STACK:
7406 cob_runtime_error (_("stack overflow, possible PERFORM depth exceeded"));
7407 break;
7408 /* LCOV_EXCL_STOP */
7409 /* LCOV_EXCL_START */
7410 case COB_FERROR_GLOBAL:
7411 cob_runtime_error (_("invalid entry/exit in GLOBAL USE procedure"));
7412 break;
7413 /* LCOV_EXCL_STOP */
7414 /* LCOV_EXCL_START */
7415 case COB_FERROR_MEMORY:
7416 cob_runtime_error (_("unable to allocate memory"));
7417 break;
7418 /* LCOV_EXCL_STOP */
7419 /* LCOV_EXCL_START */
7420 case COB_FERROR_MODULE:
7421 cob_runtime_error (_("invalid entry into module"));
7422 break;
7423 /* LCOV_EXCL_STOP */
7424 /* Note: can be simply tested; therefore no exclusion */
7425 case COB_FERROR_RECURSIVE:
7426 /* LCOV_EXCL_LINE */
7427 if (cob_module_err) {
7428 cob_runtime_error (_("recursive CALL from '%s' to '%s' which is NOT RECURSIVE"),
7429 COB_MODULE_PTR->module_name, cob_module_err->module_name);
7430 /* LCOV_EXCL_START */
7431 /* Note: only in for old modules - not active with current generation */
7432 } else {
7433 cob_runtime_error (_("invalid recursive COBOL CALL to '%s'"),
7434 COB_MODULE_PTR->module_name);
7435 }
7436 /* LCOV_EXCL_STOP */
7437 break;
7438 /* LCOV_EXCL_START */
7439 case COB_FERROR_FREE:
7440 cob_runtime_error (_("call to %s with NULL pointer"), "cob_free");
7441 break;
7442 /* LCOV_EXCL_STOP */
7443 case COB_FERROR_FILE:
7444 file_status = cobglobptr->cob_error_file->file_status;
7445 status = COB_D2I (file_status[0]) * 10 + COB_D2I (file_status[1]);
7446 switch (status) {
7447 case COB_STATUS_10_END_OF_FILE:
7448 msg = _("end of file");
7449 break;
7450 case COB_STATUS_14_OUT_OF_KEY_RANGE:
7451 msg = _("key out of range");
7452 break;
7453 case COB_STATUS_21_KEY_INVALID:
7454 msg = _("key order not ascending");
7455 break;
7456 case COB_STATUS_22_KEY_EXISTS:
7457 msg = _("record key already exists");
7458 break;
7459 case COB_STATUS_23_KEY_NOT_EXISTS:
7460 msg = _("record key does not exist");
7461 break;
7462 case COB_STATUS_30_PERMANENT_ERROR:
7463 msg = _("permanent file error");
7464 break;
7465 case COB_STATUS_31_INCONSISTENT_FILENAME:
7466 msg = _("inconsistent file name");
7467 break;
7468 case COB_STATUS_35_NOT_EXISTS:
7469 msg = _("file does not exist");
7470 break;
7471 case COB_STATUS_37_PERMISSION_DENIED:
7472 msg = _("permission denied");
7473 break;
7474 case COB_STATUS_41_ALREADY_OPEN:
7475 msg = _("file already open");
7476 break;
7477 case COB_STATUS_42_NOT_OPEN:
7478 msg = _("file not open");
7479 break;
7480 case COB_STATUS_43_READ_NOT_DONE:
7481 msg = _("READ must be executed first");
7482 break;
7483 case COB_STATUS_44_RECORD_OVERFLOW:
7484 msg = _("record overflow");
7485 break;
7486 case COB_STATUS_46_READ_ERROR:
7487 msg = _("READ after unsuccessful READ/START");
7488 break;
7489 case COB_STATUS_47_INPUT_DENIED:
7490 msg = _("READ/START not allowed, file not open for input");
7491 break;
7492 case COB_STATUS_48_OUTPUT_DENIED:
7493 msg = _("WRITE not allowed, file not open for output");
7494 break;
7495 case COB_STATUS_49_I_O_DENIED:
7496 msg = _("DELETE/REWRITE not allowed, file not open for I-O");
7497 break;
7498 case COB_STATUS_51_RECORD_LOCKED:
7499 msg = _("record locked by another file connector");
7500 break;
7501 case COB_STATUS_57_I_O_LINAGE:
7502 msg = _("LINAGE values invalid");
7503 break;
7504 case COB_STATUS_61_FILE_SHARING:
7505 msg = _("file sharing conflict");
7506 break;
7507 /* LCOV_EXCL_START */
7508 case COB_STATUS_91_NOT_AVAILABLE:
7509 msg = _("runtime library is not configured for this operation");
7510 break;
7511 /* LCOV_EXCL_STOP */
7512 /* LCOV_EXCL_START */
7513 default:
7514 msg = _("unknown file error");
7515 break;
7516 /* LCOV_EXCL_STOP */
7517 }
7518 err_cause = cob_get_filename_print (cobglobptr->cob_error_file, 1);
7519 /* FIXME: additional check if referenced program has active code location */
7520 if (!cobglobptr->last_exception_statement) {
7521 cob_runtime_error (_ ("%s (status = %02d) for file %s"),
7522 msg, status, err_cause);
7523 } else {
7524 cob_runtime_error (_("%s (status = %02d) for file %s on %s"),
7525 msg, status, err_cause,
7526 cobglobptr->last_exception_statement);
7527 }
7528 break;
7529 /* LCOV_EXCL_START */
7530 case COB_FERROR_FUNCTION:
7531 cob_runtime_error (_("attempt to use non-implemented function"));
7532 break;
7533 case COB_FERROR_XML:
7534 cob_runtime_error (_("attempt to use non-implemented XML I/O"));
7535 break;
7536 case COB_FERROR_JSON:
7537 cob_runtime_error (_("attempt to use non-implemented JSON I/O"));
7538 break;
7539 default:
7540 /* internal rare error, no need for translation */
7541 cob_runtime_error ("unknown failure: %d", fatal_error);
7542 break;
7543 /* LCOV_EXCL_STOP */
7544 }
7545 cob_stop_run (1);
7546 }
7547
7548 void
7549 conf_runtime_error_value (const char *value, const int pos)
7550 {
7551 const char *name = NULL;
7552
7553 if (gc_conf[pos].data_type & STS_CNFSET) {
7554 name = gc_conf[pos].conf_name;
7555 } else {
7556 name = gc_conf[pos].env_name;
7557 }
7558 conf_runtime_error (0, _("invalid value '%s' for configuration tag '%s'"), value, name);
7559 }
7560
7561 void
7562 conf_runtime_error (const int finish_error, const char *fmt, ...)
7563 {
7564 va_list args;
7565
7566 if (!conf_runtime_error_displayed) {
7567 conf_runtime_error_displayed = 1;
7568 fputs (_("configuration error:"), stderr);
7569 putc ('\n', stderr);
7570 }
7571
7572 /* Prefix; note: no need to strcmp as we check against
7573 the value passed last time */
7574 if (cob_source_file != last_runtime_error_file
7575 || cob_source_line != last_runtime_error_line) {
7576 last_runtime_error_file = cob_source_file;
7577 last_runtime_error_line = cob_source_line;
7578 if (cob_source_file) {
7579 fprintf (stderr, "%s", cob_source_file);
7580 if (cob_source_line) {
7581 fprintf (stderr, ":%u", cob_source_line);
7582 }
7583 } else {
7584 fprintf (stderr, "%s", _("environment variables"));
7585 }
7586 fputc(':', stderr);
7587 fputc(' ', stderr);
7588 }
7589
7590 /* Body */
7591 va_start (args, fmt);
7592 vfprintf (stderr, fmt, args);
7593 va_end (args);
7594
7595 /* Postfix */
7596 if (!finish_error) {
7597 putc (';', stderr);
7598 putc ('\n', stderr);
7599 putc ('\t', stderr);
7600 } else {
7601 putc ('\n', stderr);
7602 fflush (stderr);
7603 }
7604 }
7605
7606 #if defined (COB_GEN_SCREENIO)
7607 /* resolve curses library related version information
7608 stores the information in the version_buffer parameter
7609 returns the mouse info */
7610 static const char *
7611 get_screenio_and_mouse_info (char *version_buffer, size_t size, const int verbose)
7612 {
7613 const char *mouse_support = _("unknown");
7614 int major, minor, patch;
7615 #if defined (__PDCURSES__)
7616 int opt1, opt2, opt3;
7617 #if defined (PDC_FORCE_UTF8)
7618 const int utf8 = 1;
7619 #else
7620 const int utf8 = 0;
7621 #endif
7622 #endif
7623 #if defined (__PDCURSES__) || defined (NCURSES_VERSION)
7624 #if defined (PDC_WIDE) || defined (NCURSES_WIDECHAR)
7625 const int wide = 1;
7626 #else
7627 const int wide = 0;
7628 #endif
7629 #endif
7630 char buff[56] = {'\0'};
7631
7632 memset (version_buffer, 0, size--);
7633
7634 if (verbose) {
7635 initscr ();
7636 }
7637 #ifdef HAVE_HAS_MOUSE
7638 if (verbose) {
7639 int mouse_available = 0;
7640 mousemask (ALL_MOUSE_EVENTS, NULL);
7641 if (has_mouse () == TRUE) mouse_available = 1;
7642 if (mouse_available) {
7643 mouse_support = _("yes");
7644 } else {
7645 mouse_support = _("no");
7646 }
7647 }
7648 #elif defined (NCURSES_MOUSE_VERSION)
7649 #if defined (__PDCURSES__)
7650 mouse_support = _("yes");
7651 #endif
7652 #else
7653 mouse_support = _("disabled");
7654 #endif
7655 if (verbose) {
7656 endwin ();
7657 }
7658
7659 #if defined (__PDCURSES__) || defined (NCURSES_VERSION)
7660 #if defined (__PDCURSES__)
7661 #if defined (PDC_VER_MAJOR)
7662 #define CURSES_CMP_MAJOR PDC_VER_MAJOR
7663 #define CURSES_CMP_MINOR PDC_VER_MINOR
7664 #if PDC_VER_MAJOR == 3 && PDC_BUILD >= 3703
7665 #define RESOLVED_PDC_VER
7666 {
7667 PDC_VERSION ver;
7668 PDC_get_version (&ver);
7669 major = ver.major;
7670 minor = ver.minor;
7671 patch = 0;
7672 opt1 = ver.csize * 8;
7673 opt2 = ver.flags & PDC_VFLAG_WIDE;
7674 opt3 = ver.flags & PDC_VFLAG_UTF8;
7675 }
7676 #elif defined (PDC_HAS_VERSION_INFO)
7677 #define RESOLVED_PDC_VER
7678 {
7679 major = PDC_version.ver_major;
7680 minor = PDC_version.ver_minor;
7681 patch = PDC_version.ver_change;
7682 opt1 = PDC_version.chtype_size * 8;
7683 opt2 = PDC_version.is_wide;
7684 opt3 = PDC_version.is_forced_utf8;
7685 }
7686 #else
7687 COB_UNUSED (opt1);
7688 COB_UNUSED (opt2);
7689 COB_UNUSED (opt3);
7690 #endif
7691 #else
7692 #define CURSES_CMP_MAJOR (PDC_BUILD / 1000)
7693 #define CURSES_CMP_MINOR (PDC_BUILD - CURSES_CMP_MAJOR * 1000) / 100
7694 COB_UNUSED (opt1);
7695 COB_UNUSED (opt2);
7696 COB_UNUSED (opt3);
7697 #endif
7698 #elif defined (NCURSES_VERSION)
7699 #define CURSES_CMP_MAJOR NCURSES_VERSION_MAJOR
7700 #define CURSES_CMP_MINOR NCURSES_VERSION_MINOR
7701 #endif
7702 #if !defined (RESOLVED_PDC_VER)
7703 snprintf (version_buffer, size, "%s", curses_version ());
7704 major = 0, minor = 0, patch = 0;
7705 if ((sscanf (version_buffer, "%55s %55s %d.%d.%d", (char *)&buff, (char *)&buff, &major, &minor, &patch) < 4)
7706 && (sscanf (version_buffer, "%55s %d.%d.%d", (char *)&buff, &major, &minor, &patch) < 3)
7707 && (sscanf (version_buffer, "%d.%d.%d", &major, &minor, &patch) < 2)) {
7708 major = 0, minor = 0;
7709 }
7710 #endif
7711 if (major == CURSES_CMP_MAJOR && minor == CURSES_CMP_MINOR) {
7712 snprintf (buff, 55, _("%s, version %d.%d.%d"), WITH_CURSES, major, minor, patch);
7713 } else if (major != 0) {
7714 snprintf (buff, 55, _("%s, version %d.%d.%d (compiled with %d.%d)"),
7715 WITH_CURSES, major, minor, patch, CURSES_CMP_MAJOR, CURSES_CMP_MINOR);
7716 } else {
7717 snprintf (buff, 55, _("%s, version %s"), WITH_CURSES, version_buffer);
7718 }
7719 #if defined (RESOLVED_PDC_VER)
7720 {
7721 const int chtype_val = (int)sizeof (chtype) * 8;
7722 char chtype_def[10] = { '\0' };
7723 char wide_def[6] = {'\0'};
7724 char utf8_def[6] = {'\0'};
7725 const char *match;
7726 if (chtype_val != opt1) {
7727 match = "!";
7728 } else {
7729 match = "";
7730 }
7731 snprintf (chtype_def, 9, "%d[%d%s]", chtype_val, opt1, match);
7732 if (wide != opt2) {
7733 match = "!";
7734 } else {
7735 match = "";
7736 }
7737 snprintf (wide_def, 5, "%d[%d%s]", wide, opt2, match);
7738 if (wide != opt2) {
7739 match = "!";
7740 } else {
7741 match = "";
7742 }
7743 snprintf (utf8_def, 5, "%d[%d%s]", utf8, opt3, match);
7744 snprintf (version_buffer, size, "%s (CHTYPE=%s, WIDE=%s, UTF8=%s)",
7745 buff, chtype_def, wide_def, utf8_def);
7746 }
7747 #undef RESOLVED_PDC_VER
7748 #elif defined (__PDCURSES__)
7749 snprintf (version_buffer, size, "%s (CHTYPE=%d, WIDE=%d, UTF8=%d)", buff,
7750 (int)sizeof (chtype) * 8, wide, utf8);
7751 #else
7752 snprintf (version_buffer, size, "%s (CHTYPE=%d, WIDE=%d)", buff,
7753 (int)sizeof (chtype) * 8, wide);
7754 #endif
7755
7756 #else /* defined (__PDCURSES__) || defined (NCURSES_VERSION) */
7757 snprintf (version_buffer, size, "%s (CHTYPE=%d)", WITH_CURSES,
7758 (int)sizeof (chtype) * 8);
7759 #endif
7760
7761 if (verbose) {
7762 size_t curr_size = strlen (version_buffer);
7763 snprintf (version_buffer + curr_size, size - curr_size, " %s",
7764 longname ());
7765 endwin ();
7766 }
7767
7768 return mouse_support;
7769 }
7770 #endif
7771
7772 /* resolve math library related version information
7773 stores the information in the version_buffer parameter */
7774 static void
7775 get_math_info (char *version_buffer, size_t size, const int verbose)
7776 {
7777 int major, minor, patch;
7778 size_t curr_size;
7779 COB_UNUSED (verbose);
7780
7781 memset (version_buffer, 0, size--);
7782 major = 0, minor = 0, patch = 0;
7783 (void)sscanf (gmp_version, "%d.%d.%d", &major, &minor, &patch);
7784 if (major == __GNU_MP_VERSION && minor == __GNU_MP_VERSION_MINOR) {
7785 curr_size = snprintf (version_buffer, size, _("%s, version %d.%d.%d"), "GMP", major, minor, patch);
7786 } else {
7787 curr_size = snprintf (version_buffer, size, _("%s, version %d.%d.%d (compiled with %d.%d)"),
7788 "GMP", major, minor, patch, __GNU_MP_VERSION, __GNU_MP_VERSION_MINOR);
7789 }
7790 #if defined (mpir_version)
7791 major = 0, minor = 0, patch = 0;
7792 (void)sscanf (mpir_version, "%d.%d.%d", &major, &minor, &patch);
7793 {
7794 const char *deli = " - ";
7795 curr_size += snprintf (version_buffer + curr_size, size - curr_size, "%s", deli);
7796 }
7797
7798 if (major == __MPIR_VERSION && minor == __MPIR_VERSION_MINOR) {
7799 snprintf (version_buffer + curr_size, size - curr_size,
7800 _("%s, version %d.%d.%d"),
7801 "MPIR", major, minor, patch);
7802 } else {
7803 snprintf (version_buffer + curr_size, size - curr_size,
7804 _("%s, version %d.%d.%d (compiled with %d.%d)"),
7805 "MPIR", major, minor, patch, __MPIR_VERSION, __MPIR_VERSION_MINOR);
7806 }
7807 #else
7808 COB_UNUSED (curr_size);
7809 #endif
7810 }
7811
7812 /* internal library version as string,
7813 note: the patchlevel may differ from the package one */
7814 const char* libcob_version () {
7815
7816 /* FIXME: replace this define by a general one (COB_TREE_DEBUG) _was_ for debugging
7817 the parse tree only ... */
7818 #if defined (COB_TREE_DEBUG) || defined (_DEBUG)
7819 {
7820 int major, minor;
7821 major = 0, minor = 0;
7822 (void)sscanf (PACKAGE_VERSION, "%d.%d", &major, &minor);
7823 /* LCOV_EXCL_START */
7824 if (major != __LIBCOB_VERSION || minor != __LIBCOB_VERSION_MINOR) {
7825 const char* version = CB_XSTRINGIFY (__LIBCOB_VERSION) "."
7826 CB_XSTRINGIFY (__LIBCOB_VERSION_MINOR);
7827 cob_runtime_error (_("version mismatch"));
7828 cob_runtime_hint (_("%s has version %s.%d"), "libcob internally",
7829 version, __LIBCOB_VERSION_PATCHLEVEL);
7830 cob_runtime_hint (_("%s has version %s.%d"), "libcob package",
7831 PACKAGE_VERSION, PATCH_LEVEL);
7832 cob_stop_run (1);
7833 }
7834 /* LCOV_EXCL_STOP */
7835 {
7836 int check, patch;
7837 patch = 0;
7838 check = set_libcob_version (&major, &minor, &patch);
7839 /* LCOV_EXCL_START */
7840 if (check != 0 && check != 3) {
7841 cob_runtime_error (_("version mismatch"));
7842 /* untranslated as it is very unlikely to happen */
7843 cob_runtime_hint ("internal version check differs at %d\n", check);
7844 cob_stop_run (1);
7845 }
7846 /* LCOV_EXCL_STOP */
7847 }
7848 }
7849 #endif
7850 return CB_XSTRINGIFY (__LIBCOB_VERSION) "."
7851 CB_XSTRINGIFY (__LIBCOB_VERSION_MINOR) "."
7852 CB_XSTRINGIFY (__LIBCOB_VERSION_PATCHLEVEL);
7853 }
7854
7855 /* internal library version set/compare,
7856 if 'mayor' is not 0 on entry compares against the given
7857 values, returns the parameter that is not matching
7858 given parameters will be set to the internal values on exit
7859 note: the patchlevel may differ from the package one */
7860 int set_libcob_version (int *mayor, int *minor, int *patch) {
7861 int ret = 0;
7862 if (*mayor != 0) {
7863 if (*mayor != __LIBCOB_VERSION) {
7864 ret = 1;
7865 } else if (*minor != __LIBCOB_VERSION_MINOR) {
7866 ret = 2;
7867 } else if (*patch != __LIBCOB_VERSION_PATCHLEVEL) {
7868 ret = 3;
7869 }
7870 }
7871 *mayor = __LIBCOB_VERSION;
7872 *minor = __LIBCOB_VERSION_MINOR;
7873 *patch = __LIBCOB_VERSION_PATCHLEVEL;
7874 return ret;
7875 }
7876
7877 static void set_cob_build_stamp (char *cob_build_stamp)
7878 {
7879 int status, day, year;
7880 char month[64];
7881
7882 /* Set up build time stamp */
7883 memset (cob_build_stamp, 0, (size_t)COB_MINI_BUFF);
7884 memset (month, 0, sizeof (month));
7885 day = 0;
7886 year = 0;
7887 status = sscanf (__DATE__, "%63s %d %d", month, &day, &year);
7888 if (status == 3) {
7889 snprintf (cob_build_stamp, (size_t)COB_MINI_MAX,
7890 "%s %2.2d %4.4d %s", month, day, year, __TIME__);
7891 } else {
7892 snprintf (cob_build_stamp, (size_t)COB_MINI_MAX,
7893 "%s %s", __DATE__, __TIME__);
7894 }
7895 }
7896
7897 /* provides a two line output for GnuCOBOL + C compiler and used libraries */
7898 void
7899 print_version_summary (void)
7900 {
7901 char cob_build_stamp[COB_MINI_BUFF];
7902
7903 set_cob_build_stamp (cob_build_stamp);
7904
7905 printf ("%s %s (%s), ",
7906 PACKAGE_NAME, libcob_version(), cob_build_stamp);
7907
7908 /* note: some compilers use a very long identifier */
7909 printf ("%s\n", GC_C_VERSION_PRF GC_C_VERSION);
7910
7911 printf ("%s %d.%d.%d",
7912 #ifdef __MPIR_VERSION
7913 "MPIR", __MPIR_VERSION, __MPIR_VERSION_MINOR, __MPIR_VERSION_PATCHLEVEL
7914 #else
7915 "GMP", __GNU_MP_VERSION, __GNU_MP_VERSION_MINOR, __GNU_MP_VERSION_PATCHLEVEL
7916 #endif
7917 );
7918
7919 #if defined (LIBXML_VERSION)
7920 printf (", libxml2 %d.%d.%d",
7921 LIBXML_VERSION / 10000,
7922 (LIBXML_VERSION - (int)(LIBXML_VERSION / 10000) * 10000) / 100,
7923 LIBXML_VERSION % 100);
7924 #endif
7925
7926 #if defined (CJSON_VERSION_MAJOR)
7927 printf (", cJSON %d.%d.%d",
7928 CJSON_VERSION_MAJOR, CJSON_VERSION_MINOR, CJSON_VERSION_PATCH);
7929 #endif
7930 #if defined (JSON_C_MAJOR_VERSION)
7931 printf (", JSON-c %d.%d.%d",
7932 JSON_C_MAJOR_VERSION, JSON_C_MINOR_VERSION, JSON_C_MICRO_VERSION);
7933 #endif
7934 #if defined (PDC_VER_MAJOR)
7935 printf (", %s %d.%d",
7936 #ifdef PDC_VER_YEAR /* still the correct distinction in 2020 */
7937 "PDCursesMod",
7938 #else
7939 "PDCurses",
7940 #endif
7941 PDC_VER_MAJOR, PDC_VER_MINOR);
7942 #ifdef PDC_VER_CHANGE
7943 printf (".%d", PDC_VER_CHANGE);
7944 #endif
7945 #endif
7946 #if defined (NCURSES_VERSION_MAJOR)
7947 printf (", %s %d.%d.%d",
7948 #ifdef NCURSES_WIDECHAR
7949 "ncursesw",
7950 #else
7951 "ncurses",
7952 #endif
7953 NCURSES_VERSION_MAJOR, NCURSES_VERSION_MINOR, NCURSES_VERSION_PATCH);
7954 #endif
7955
7956 #if defined (WITH_DB)
7957 printf (", BDB %d.%d.%d",
7958 DB_VERSION_MAJOR, DB_VERSION_MINOR, DB_VERSION_PATCH);
7959 #endif
7960 #if defined (WITH_CISAM)
7961 printf (", C-ISAM");
7962 #endif
7963 #if defined (WITH_DISAM)
7964 printf (", D-ISAM");
7965 #endif
7966 #if defined (WITH_VBISAM)
7967 printf (", VB-ISAM");
7968 #endif
7969 putchar ('\n');
7970
7971 }
7972
7973 void
7974 print_version (void)
7975 {
7976 char cob_build_stamp[COB_MINI_BUFF];
7977
7978 set_cob_build_stamp (cob_build_stamp);
7979
7980 printf ("libcob (%s) %s.%d\n",
7981 PACKAGE_NAME, PACKAGE_VERSION, PATCH_LEVEL);
7982 puts ("Copyright (C) 2020 Free Software Foundation, Inc.");
7983 puts (_("License LGPLv3+: GNU LGPL version 3 or later <http://gnu.org/licenses/lgpl.html>"));
7984 puts (_("This is free software; see the source for copying conditions. There is NO\n"
7985 "warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE."));
7986 printf (_("Written by %s\n"), "Keisuke Nishida, Roger While, Ron Norman, Simon Sobisch, Edward Hart");
7987
7988 /* TRANSLATORS: This msgid is intended as the "Packaged" msgid, %s expands to date and time */
7989 printf (_("Built %s"), cob_build_stamp);
7990 putchar ('\n');
7991 /* TRANSLATORS: This msgid is intended as the "Built" msgid, %s expands to date and time */
7992 printf (_("Packaged %s"), COB_TAR_DATE);
7993 putchar ('\n');
7994 }
7995
7996 void
7997 print_info (void)
7998 {
7999 print_info_detailed (0);
8000 }
8001
8002 void
8003 print_info_detailed (const int verbose)
8004 {
8005 char screenio_info[150];
8006 const char *mouse_support;
8007
8008 char buff[56] = { '\0' };
8009 char *s;
8010
8011 /* resolving screenio related information before anything else as this
8012 function will possibly run initscr + endwin and therefore
8013 may interfer with other output */
8014 #if defined (COB_GEN_SCREENIO)
8015 mouse_support = get_screenio_and_mouse_info
8016 ((char*)&screenio_info, sizeof (screenio_info), verbose);
8017 #else
8018 snprintf ((char *)&screenio_info, sizeof(screenio_info) - 1,
8019 "%s", _("disabled"));
8020 mouse_support = _("disabled");
8021 #endif
8022
8023 print_version ();
8024 putchar ('\n');
8025 puts (_("build information"));
8026 var_print (_("build environment"), COB_BLD_BUILD, "", 0);
8027 var_print ("CC", COB_BLD_CC, "", 0);
8028 /* Note: newline because most compilers define a long version string (> 30 characters) */
8029 var_print (_("C version"), GC_C_VERSION_PRF GC_C_VERSION, "", 0);
8030 var_print ("CPPFLAGS", COB_BLD_CPPFLAGS, "", 0);
8031 var_print ("CFLAGS", COB_BLD_CFLAGS, "", 0);
8032 var_print ("LD", COB_BLD_LD, "", 0);
8033 var_print ("LDFLAGS", COB_BLD_LDFLAGS, "", 0);
8034 putchar ('\n');
8035
8036 puts (_("GnuCOBOL information"));
8037
8038 var_print ("COB_MODULE_EXT", COB_MODULE_EXT, "", 0);
8039 #if 0 /* only relevant for cobc */
8040 var_print ("COB_OBJECT_EXT", COB_OBJECT_EXT, "", 0);
8041 var_print ("COB_EXE_EXT", COB_EXE_EXT, "", 0);
8042 #endif
8043
8044 #if defined (USE_LIBDL) || defined (_WIN32)
8045 var_print (_("dynamic loading"), "system", "", 0);
8046 #else
8047 var_print (_("dynamic loading"), "libtool", "", 0);
8048 #endif
8049
8050 if (verbose) {
8051 #ifdef COB_PARAM_CHECK
8052 var_print ("\"CBL_\" param check", _("enabled"), "", 0);
8053 #else
8054 var_print ("\"CBL_\" param check", _("disabled"), "", 0);
8055 #endif
8056 }
8057 #ifdef COB_64_BIT_POINTER
8058 var_print ("64bit-mode", _("yes"), "", 0);
8059 #else
8060 var_print ("64bit-mode", _("no"), "", 0);
8061 #endif
8062
8063 #ifdef COB_LI_IS_LL
8064 var_print ("BINARY-C-LONG", _("8 bytes"), "", 0);
8065 #else
8066 var_print ("BINARY-C-LONG", _("4 bytes"), "", 0);
8067 #endif
8068
8069 #ifdef WORDS_BIGENDIAN
8070 var_print (_("endianness"), _("big-endian"), "", 0);
8071 #else
8072 var_print (_("endianness"), _("little-endian"), "", 0);
8073 #endif
8074
8075 #ifdef COB_EBCDIC_MACHINE
8076 var_print (_("native EBCDIC"), _("yes"), "", 0);
8077 #else
8078 var_print (_("native EBCDIC"), _("no"), "", 0);
8079 #endif
8080
8081 snprintf (buff, sizeof (buff), "%d", WITH_VARSEQ);
8082 var_print (_("variable file format"), buff, "", 0);
8083 if ((s = getenv ("COB_VARSEQ_FORMAT")) != NULL) {
8084 var_print ("COB_VARSEQ_FORMAT", s, "", 1);
8085 }
8086
8087 #ifdef WITH_SEQRA_EXTFH
8088 var_print (_("sequential file handler"), "EXTFH", "", 0);
8089 #else
8090 var_print (_("sequential file handler"), _("built-in"), "", 0);
8091 #endif
8092
8093 #if defined (WITH_INDEX_EXTFH)
8094 var_print (_("indexed file handler"), "EXTFH", "", 0);
8095 #elif defined (WITH_DB)
8096 {
8097 int major, minor, patch;
8098 major = 0, minor = 0, patch = 0;
8099 db_version (&major, &minor, &patch);
8100 if (major == DB_VERSION_MAJOR && minor == DB_VERSION_MINOR) {
8101 snprintf (buff, 55, _("%s, version %d.%d.%d"),
8102 "BDB", major, minor, patch);
8103 } else {
8104 snprintf (buff, 55, _("%s, version %d.%d.%d (compiled with %d.%d)"),
8105 "BDB", major, minor, patch, DB_VERSION_MAJOR, DB_VERSION_MINOR);
8106 }
8107 }
8108 var_print (_("indexed file handler"), buff, "", 0);
8109 #elif defined (WITH_CISAM)
8110 var_print (_("indexed file handler"), "C-ISAM", "", 0);
8111 #elif defined (WITH_DISAM)
8112 var_print (_("indexed file handler"), "D-ISAM", "", 0);
8113 #elif defined (WITH_VBISAM)
8114 #if defined (VB_RTD)
8115 var_print (_("indexed file handler"), "VBISAM (RTD)", "", 0);
8116 #else
8117 var_print (_("indexed file handler"), "VBISAM", "", 0);
8118 #endif
8119 #else
8120 var_print (_("indexed file handler"), _("disabled"), "", 0);
8121 #endif
8122
8123 {
8124 char math_info[115];
8125 get_math_info ((char*)&math_info, sizeof (math_info), verbose);
8126 var_print (_("mathematical library"), (char *)&math_info, "", 0);
8127 }
8128
8129 #ifdef WITH_XML2
8130 {
8131 int major, minor, patch;
8132 major = LIBXML_VERSION / 10000;
8133 minor = (LIBXML_VERSION - major * 10000) / 100 ;
8134 patch = LIBXML_VERSION - major * 10000 - minor * 100;
8135 snprintf (buff, 55, _("%s, version %d.%d.%d"),
8136 "libxml2", major, minor, patch);
8137 var_print (_("XML library"), buff, "", 0);
8138 LIBXML_TEST_VERSION
8139 xmlCleanupParser ();
8140 }
8141 #else
8142 var_print (_("XML library"), _("disabled"), "", 0);
8143 #endif
8144
8145
8146 #if defined (WITH_CJSON)
8147 {
8148 int major, minor, patch;
8149 major = 0, minor = 0, patch = 0;
8150 (void)sscanf (cJSON_Version(), "%d.%d.%d", &major, &minor, &patch);
8151 if (major == CJSON_VERSION_MAJOR && minor == CJSON_VERSION_MINOR) {
8152 snprintf (buff, 55, _("%s, version %d.%d.%d"),
8153 "cJSON", major, minor, patch);
8154 } else {
8155 snprintf (buff, 55, _("%s, version %d.%d.%d (compiled with %d.%d)"),
8156 "cJSON", major, minor, patch, CJSON_VERSION_MAJOR, CJSON_VERSION_MINOR);
8157 }
8158 }
8159 var_print (_("JSON library"), buff, "", 0);
8160
8161 #elif defined (WITH_JSON_C)
8162 {
8163 int major, minor, patch;
8164 major = 0, minor = 0, patch = 0;
8165 (void)sscanf (json_c_version (), "%d.%d.%d", &major, &minor, &patch);
8166 if (major == JSON_C_MAJOR_VERSION && minor == JSON_C_MINOR_VERSION) {
8167 snprintf (buff, 55, _("%s, version %d.%d.%d"),
8168 "json-c", major, minor, patch);
8169 } else {
8170 snprintf (buff, 55, _("%s, version %d.%d.%d (compiled with %d.%d)"),
8171 "json-c", major, minor, patch, JSON_C_MAJOR_VERSION, JSON_C_MINOR_VERSION);
8172 }
8173 }
8174 var_print (_("JSON library"), buff, "", 0);
8175 #else
8176 var_print (_("JSON library"), _("disabled"), "", 0);
8177 #endif
8178
8179 var_print (_("extended screen I/O"), (char*)&screenio_info, "", 0);
8180 var_print (_("mouse support"), mouse_support, "", 0);
8181
8182 #ifdef COB_DEBUG_LOG
8183 var_print ("DEBUG_LOG", _("enabled"), "", 0);
8184 #endif
8185 }
8186
8187 void
8188 print_runtime_conf ()
8189 {
8190 unsigned int i, j, k, vl, dohdg, hdlen, plen, plen2;
8191 char value[COB_MEDIUM_BUFF], orgvalue[COB_MINI_BUFF];
8192
8193 #ifdef ENABLE_NLS /* note: translated version of definition values */
8194 #ifdef HAVE_SETLOCALE
8195 const char *s;
8196 #endif
8197 setting_group[1] = _("CALL configuration");
8198 setting_group[2] = _("File I/O configuration");
8199 setting_group[3] = _("Screen I/O configuration");
8200 setting_group[4] = _("Miscellaneous");
8201 setting_group[5] = _("System configuration");
8202 #endif
8203
8204 printf ("%s %s.%d ", PACKAGE_NAME, PACKAGE_VERSION, PATCH_LEVEL);
8205 puts (_("runtime configuration"));
8206 if (cobsetptr->cob_config_file) {
8207 strncpy (value, _("via"), (size_t)COB_MEDIUM_MAX);
8208 value[COB_MEDIUM_MAX] = 0;
8209 hdlen = (unsigned int)strlen (value) + 3;
8210
8211 /* output path of main configuration file */
8212 printf (" %s ", value);
8213 plen = 80 - hdlen;
8214 strncpy (value, cobsetptr->cob_config_file[0], (size_t)COB_MEDIUM_MAX);
8215 value[COB_MEDIUM_MAX] = 0;
8216 vl = (unsigned int)strlen (value);
8217 for (k = 0; vl > plen; vl -= plen, k += plen) {
8218 printf ("%.*s\n%-*s", plen, &value[k], hdlen, "");
8219 }
8220 printf ("%s\n", &value[k]);
8221
8222 /* output path of additional configuration files */
8223 for (i = 1; i < cobsetptr->cob_config_num; i++) {
8224 printf ("%*d ", hdlen - 2, i);
8225 strncpy (value, cobsetptr->cob_config_file[i], (size_t)COB_MEDIUM_MAX);
8226 value[COB_MEDIUM_MAX] = 0;
8227 vl = (unsigned int)strlen (value);
8228 for (k = 0; vl > plen; vl -= plen, k += plen) {
8229 printf ("%.*s\n%-*s", plen, &value[k], hdlen, "");
8230 }
8231 printf ("%s\n", &value[k]);
8232 }
8233
8234 }
8235 putchar ('\n');
8236 strcpy (value, "todo");
8237 hdlen = 15;
8238 for (i = 0; i < NUM_CONFIG; i++) {
8239 j = (unsigned int)strlen (gc_conf[i].env_name);
8240 if (j > hdlen)
8241 hdlen = j;
8242 j = (unsigned int)strlen (gc_conf[i].conf_name);
8243 if (j > hdlen)
8244 hdlen = j;
8245 }
8246
8247 for (j = 1; j < GRP_MAX; j++) {
8248 dohdg = 1;
8249 for (i = 0; i < NUM_CONFIG; i++) {
8250 if (gc_conf[i].env_group == j) {
8251 if (dohdg) {
8252 dohdg = 0;
8253 if (j > 1) {
8254 putchar ('\n');
8255 }
8256 printf (" %s\n", setting_group[j]);
8257 }
8258 /* Convert value back into string and display it */
8259 get_config_val (value, i, orgvalue);
8260 if ((gc_conf[i].data_type & STS_ENVSET)
8261 || (gc_conf[i].data_type & STS_FNCSET)) {
8262 putchar (' ');
8263 if (gc_conf[i].data_type & STS_FNCSET) {
8264 printf (" ");
8265 } else if ((gc_conf[i].data_type & STS_CNFSET)) {
8266 printf ("Ovr");
8267 } else {
8268 printf ("env");
8269 if (gc_conf[i].data_loc == offsetof(cob_settings,cob_preload_str)
8270 && cobsetptr->cob_preload_str_set != NULL) {
8271 printf (": %-*s : ", hdlen, gc_conf[i].env_name);
8272 printf ("%s\n", cobsetptr->cob_preload_str_set);
8273 printf ("eval");
8274 }
8275 }
8276 printf (": %-*s : ", hdlen, gc_conf[i].env_name);
8277 } else if ((gc_conf[i].data_type & STS_CNFSET)) {
8278 if ((gc_conf[i].data_type & STS_ENVCLR)) {
8279 printf (" : %-*s : ", hdlen, gc_conf[i].env_name);
8280 puts (_("... removed from environment"));
8281 }
8282 if (gc_conf[i].config_num > 0) {
8283 printf (" %d ", gc_conf[i].config_num);
8284 } else {
8285 printf (" ");
8286 }
8287 if (gc_conf[i].data_loc == offsetof(cob_settings,cob_preload_str)
8288 && cobsetptr->cob_preload_str_set != NULL) {
8289 printf (": %-*s : ",hdlen,
8290 gc_conf[i].set_by > 0 ? gc_conf[i].env_name
8291 : gc_conf[i].conf_name);
8292 printf ("%s\n",cobsetptr->cob_preload_str_set);
8293 printf ("eval");
8294 }
8295 if (gc_conf[i].set_by > 0) {
8296 printf (": %-*s : ", hdlen, gc_conf[i].env_name);
8297 } else {
8298 printf (": %-*s : ", hdlen, gc_conf[i].conf_name);
8299 }
8300 } else if (gc_conf[i].env_name) {
8301 if (gc_conf[i].config_num > 0){
8302 printf (" %d ", gc_conf[i].config_num);
8303 } else {
8304 printf (" ");
8305 }
8306 printf (": %-*s : ", hdlen, gc_conf[i].env_name);
8307 if ((gc_conf[i].data_type & STS_ENVCLR)) {
8308 puts (_("... removed from environment"));
8309 continue;
8310 }
8311 } else {
8312 printf (" : %-*s : ", hdlen, gc_conf[i].conf_name);
8313 }
8314 vl = (unsigned int)strlen (value);
8315 plen = 71 - hdlen;
8316 if (vl < min_conf_length) {
8317 plen2 = min_conf_length - vl;
8318 } else if (vl == min_conf_length) {
8319 plen2 = 1;
8320 } else {
8321 plen2 = 0;
8322 }
8323 for (k = 0; vl > plen; vl -= plen, k += plen) {
8324 printf ("%.*s\n %-*s : ", plen, &value[k], hdlen, "");
8325 }
8326 printf ("%s", &value[k]);
8327 printf ("%.*s", plen2, " ");
8328 if (orgvalue[0]) {
8329 printf (" (%s)", orgvalue);
8330 }
8331 if (gc_conf[i].set_by != 0) {
8332 putchar (' ');
8333 if (gc_conf[i].set_by != FUNC_NAME_IN_DEFAULT) {
8334 printf (_("(set by %s)"), gc_conf[gc_conf[i].set_by].env_name);
8335 } else {
8336 printf (_("(set by %s)"), gc_conf[i].default_val);
8337 }
8338 }
8339 if (!(gc_conf[i].data_type & STS_ENVSET)
8340 && !(gc_conf[i].data_type & STS_CNFSET)
8341 && !(gc_conf[i].data_type & STS_FNCSET)) {
8342 putchar (' ');
8343 if ((gc_conf[i].data_type & STS_RESET)) {
8344 printf (_("(reset)"));
8345 } else if (strcmp (value, not_set) != 0) {
8346 printf (_("(default)"));
8347 }
8348 }
8349 putchar ('\n');
8350 }
8351 }
8352 }
8353
8354
8355 #ifdef HAVE_SETLOCALE
8356 #ifdef ENABLE_NLS
8357 s = getenv ("LOCALEDIR");
8358 printf (" : %-*s : %s\n", hdlen, "LOCALEDIR", s ? s : LOCALEDIR);
8359 #endif
8360 printf (" : %-*s : %s\n", hdlen, "LC_CTYPE", setlocale (LC_CTYPE, NULL));
8361 printf (" : %-*s : %s\n", hdlen, "LC_NUMERIC", setlocale (LC_NUMERIC, NULL));
8362 printf (" : %-*s : %s\n", hdlen, "LC_COLLATE", setlocale (LC_COLLATE, NULL));
8363 #ifdef LC_MESSAGES
8364 printf (" : %-*s : %s\n", hdlen, "LC_MESSAGES", setlocale (LC_MESSAGES, NULL));
8365 #endif
8366 printf (" : %-*s : %s\n", hdlen, "LC_MONETARY", setlocale (LC_MONETARY, NULL));
8367 printf (" : %-*s : %s\n", hdlen, "LC_TIME", setlocale (LC_TIME, NULL));
8368 #endif
8369 }
8370
8371 cob_settings *
8372 cob_get_settings_ptr ()
8373 {
8374 return cobsetptr;
8375 }
8376
8377 void
8378 cob_init_nomain (const int argc, char **argv)
8379 {
8380 check_mainhandle = 0;
8381 cob_init (argc, argv);
8382 }
8383
8384 void
8385 cob_common_init (void *setptr)
8386 {
8387 #ifdef ENABLE_NLS
8388 {
8389 struct stat localest;
8390 const char * localedir;
8391
8392 localedir = getenv ("LOCALEDIR");
8393 if (localedir != NULL
8394 && !stat (localedir, &localest)
8395 && (S_ISDIR (localest.st_mode))) {
8396 bindtextdomain (PACKAGE, localedir);
8397 } else {
8398 bindtextdomain (PACKAGE, LOCALEDIR);
8399 }
8400 textdomain (PACKAGE);
8401 }
8402 #endif
8403
8404 #ifdef _WIN32
8405 /* Allows running tests under Win */
8406 {
8407 int use_unix_lf = 0;
8408 char *s = getenv ("COB_UNIX_LF");
8409
8410 if (s != NULL) {
8411 if (setptr) {
8412 set_config_val_by_name (s, "unix_lf", NULL);
8413 use_unix_lf = cobsetptr->cob_unix_lf;
8414 } else
8415 if (*s == 'Y' || *s == 'y' ||
8416 *s == 'O' || *s == 'o' ||
8417 *s == 'T' || *s == 't' ||
8418 *s == '1') {
8419 use_unix_lf = 1;
8420 }
8421 }
8422 if (use_unix_lf) {
8423 (void)_setmode (_fileno (stdin), _O_BINARY);
8424 (void)_setmode (_fileno (stdout), _O_BINARY);
8425 (void)_setmode (_fileno (stderr), _O_BINARY);
8426 }
8427 }
8428 #endif
8429 }
8430
8431 void
8432 cob_init (const int argc, char **argv)
8433 {
8434 char *s;
8435 #if defined (HAVE_READLINK) || defined (HAVE_GETEXECNAME)
8436 const char *path;
8437 #endif
8438 int i;
8439
8440 /* Ensure initialization is only done once. Within generated modules and
8441 libcob this is already ensured, but an external caller may call this
8442 function again */
8443 if (cob_initialized) {
8444 #if 0 /* Simon: We may raise a runtime warning/error in the future here */
8445 cob_runtime_warning ("%s called more than once", "cob_init");
8446 #endif
8447 return;
8448 }
8449
8450 #ifdef __GLIBC__
8451 {
8452 /*
8453 * GNU libc may write a stack trace to /dev/tty when malloc
8454 * detects corruption. If LIBC_FATAL_STDERR_ is set to any
8455 * nonempty string, it writes to stderr instead. See:
8456 *https://code.woboq.org/userspace/glibc/sysdeps/posix/libc_fatal.c.html
8457 */
8458 if (getenv ((const char*)"LIBC_FATAL_STDERR_") == NULL ) {
8459 (void)putenv ((char*)"LIBC_FATAL_STDERR_=keep_off_the_grass");
8460 }
8461 }
8462 #endif
8463
8464 cob_set_signal ();
8465
8466 cob_alloc_base = NULL;
8467 cob_local_env = NULL;
8468 cob_last_sfile = NULL;
8469 commlnptr = NULL;
8470 basext = NULL;
8471 sort_keys = NULL;
8472 sort_collate = NULL;
8473 cob_current_program_id = NULL;
8474 cob_current_section = NULL;
8475 cob_current_paragraph = NULL;
8476 cob_source_file = NULL;
8477 cob_source_statement = NULL;
8478 exit_hdlrs = NULL;
8479 hdlrs = NULL;
8480 commlncnt = 0;
8481 sort_nkeys = 0;
8482 cob_source_line = 0;
8483 cob_local_env_size = 0;
8484
8485 current_arg = 1;
8486
8487 cob_argc = argc;
8488 cob_argv = argv;
8489
8490 /* Get emergency buffer */
8491 runtime_err_str = cob_fast_malloc ((size_t)COB_ERRBUF_SIZE);
8492
8493 /* Get global structure */
8494 cobglobptr = cob_malloc (sizeof (cob_global));
8495
8496 /* Get settings structure */
8497 cobsetptr = cob_malloc (sizeof (cob_settings));
8498
8499 cob_initialized = 1;
8500
8501 #ifdef HAVE_SETLOCALE
8502 /* Prime the locale from user settings */
8503 s = setlocale (LC_ALL, "");
8504 if (s) {
8505 /* Save initial values */
8506 cobglobptr->cob_locale_orig = cob_strdup (s);
8507 s = setlocale (LC_CTYPE, NULL);
8508 if (s) {
8509 cobglobptr->cob_locale_ctype = cob_strdup (s);
8510 }
8511 s = setlocale (LC_COLLATE, NULL);
8512 if (s) {
8513 cobglobptr->cob_locale_collate = cob_strdup (s);
8514 }
8515 #ifdef LC_MESSAGES
8516 s = setlocale (LC_MESSAGES, NULL);
8517 if (s) {
8518 cobglobptr->cob_locale_messages = cob_strdup (s);
8519 }
8520 #endif
8521 s = setlocale (LC_MONETARY, NULL);
8522 if (s) {
8523 cobglobptr->cob_locale_monetary = cob_strdup (s);
8524 }
8525 s = setlocale (LC_NUMERIC, NULL);
8526 if (s) {
8527 cobglobptr->cob_locale_numeric = cob_strdup (s);
8528 }
8529 s = setlocale (LC_TIME, NULL);
8530 if (s) {
8531 cobglobptr->cob_locale_time = cob_strdup (s);
8532 }
8533 /* Set to standard "C" locale for COBOL */
8534 setlocale (LC_NUMERIC, "C");
8535 setlocale (LC_CTYPE, "C");
8536 /* Save changed locale */
8537 s = setlocale (LC_ALL, NULL);
8538 if (s) {
8539 cobglobptr->cob_locale = cob_strdup (s);
8540 }
8541 }
8542 #endif
8543
8544 cob_common_init (cobsetptr);
8545
8546 /* Load runtime configuration file */
8547 if (unlikely (cob_load_config () < 0)) {
8548 cob_stop_run (1);
8549 }
8550
8551 /* Copy COB_PHYSICAL_CANCEL from settings (internal) to global structure */
8552 cobglobptr->cob_physical_cancel = cobsetptr->cob_physical_cancel;
8553
8554 /* Internal Debug Log */
8555 if (cobsetptr->cob_debug_log) {
8556 #ifndef COB_DEBUG_LOG
8557 cob_runtime_warning (_("compiler was not built with --enable-debug-log; COB_DEBUG_LOG ignored"));
8558 #else
8559 cob_debug_open ();
8560 #endif
8561 }
8562
8563 /* Call inits with cobsetptr to get the addresses of all */
8564 /* Screen-IO might be needed for error outputs */
8565 cob_init_screenio (cobglobptr, cobsetptr);
8566 cob_init_numeric (cobglobptr);
8567 cob_init_strings (cobglobptr);
8568 cob_init_move (cobglobptr, cobsetptr);
8569 cob_init_intrinsic (cobglobptr);
8570 cob_init_fileio (cobglobptr, cobsetptr);
8571 cob_init_call (cobglobptr, cobsetptr, check_mainhandle);
8572 cob_init_termio (cobglobptr, cobsetptr);
8573 cob_init_reportio (cobglobptr, cobsetptr);
8574 cob_init_mlio (cobglobptr);
8575
8576 /* Set up library routine stuff */
8577 cobglobptr->cob_term_buff = cob_malloc ((size_t)COB_MEDIUM_BUFF);
8578
8579 /* Set switches */
8580 for (i = 0; i <= COB_SWITCH_MAX; ++i) {
8581 sprintf (runtime_err_str, "COB_SWITCH_%d", i);
8582 s = getenv (runtime_err_str);
8583 if (s && (*s == '1' || strcasecmp (s, "ON") == 0)) {
8584 cob_switch[i] = 1;
8585 } else {
8586 cob_switch[i] = 0;
8587 }
8588 }
8589
8590 /* Get user name if not set via environment already */
8591 if (cobsetptr->cob_user_name == NULL) {
8592 #if defined (_WIN32)
8593 /* note: only defined manual (needs additional link to advapi32): */
8594 #if defined (HAVE_GETUSERNAME)
8595 unsigned long bsiz = COB_ERRBUF_SIZE;
8596 if (GetUserName (runtime_err_str, &bsiz)) {
8597 set_config_val_by_name (runtime_err_str, "username", "GetUserName()");
8598 }
8599 #endif
8600 #elif !defined(__OS400__)
8601 s = getlogin ();
8602 if (s) {
8603 set_config_val_by_name (s, "username", "getlogin()");
8604 }
8605 #endif
8606 #if 0 /* likely not needed, if unset then empty */
8607 if (cobsetptr->cob_user_name == NULL) {
8608 set_config_val_by_name (_("unknown"), "username", "cob_init()");
8609 }
8610 #endif
8611 }
8612
8613 #if defined(_MSC_VER) && COB_USE_VC2008_OR_GREATER
8614 get_function_ptr_for_precise_time ();
8615 #endif
8616
8617 /* This must be last in this function as we do early return */
8618 /* from certain ifdef's */
8619
8620 #ifdef _WIN32
8621 s = cob_malloc ((size_t)COB_LARGE_BUFF);
8622 i = GetModuleFileNameA (NULL, s, COB_LARGE_MAX);
8623 if (i > 0 && i < COB_LARGE_BUFF) {
8624 cobglobptr->cob_main_argv0 = cob_strdup (s);
8625 cob_free (s);
8626 return;
8627 }
8628 cob_free (s);
8629 #elif defined (HAVE_READLINK)
8630 path = NULL;
8631 if (!access ("/proc/self/exe", R_OK)) {
8632 path = "/proc/self/exe";
8633 } else if (!access ("/proc/curproc/file", R_OK)) {
8634 path = "/proc/curproc/file";
8635 } else if (!access ("/proc/self/path/a.out", R_OK)) {
8636 path = "/proc/self/path/a.out";
8637 }
8638 if (path) {
8639 s = cob_malloc ((size_t)COB_LARGE_BUFF);
8640 i = (int)readlink (path, s, (size_t)COB_LARGE_MAX);
8641 if (i > 0 && i < COB_LARGE_BUFF) {
8642 s[i] = 0;
8643 cobglobptr->cob_main_argv0 = cob_strdup (s);
8644 cob_free (s);
8645 return;
8646 }
8647 cob_free (s);
8648 }
8649 #endif
8650
8651 #ifdef HAVE_GETEXECNAME
8652 path = getexecname ();
8653 if (path) {
8654 #ifdef HAVE_REALPATH
8655 s = cob_malloc ((size_t)COB_LARGE_BUFF);
8656 if (realpath (path, s) != NULL) {
8657 cobglobptr->cob_main_argv0 = cob_strdup (s);
8658 } else {
8659 cobglobptr->cob_main_argv0 = cob_strdup (path);
8660 }
8661 cob_free (s);
8662 #else
8663 cobglobptr->cob_main_argv0 = cob_strdup (path);
8664 #endif
8665 return;
8666 }
8667 #endif
8668
8669 if (argc && argv && argv[0]) {
8670 #if defined (HAVE_CANONICALIZE_FILE_NAME)
8671 /* Returns malloced path or NULL */
8672 cobglobptr->cob_main_argv0 = canonicalize_file_name (argv[0]);
8673 #elif defined (HAVE_REALPATH)
8674 s = cob_malloc ((size_t)COB_LARGE_BUFF);
8675 if (realpath (argv[0], s) != NULL) {
8676 cobglobptr->cob_main_argv0 = cob_strdup (s);
8677 }
8678 cob_free (s);
8679 #elif defined (_WIN32)
8680 /* Returns malloced path or NULL */
8681 cobglobptr->cob_main_argv0 = _fullpath (NULL, argv[0], 1);
8682 #endif
8683 if (!cobglobptr->cob_main_argv0) {
8684 cobglobptr->cob_main_argv0 = cob_strdup (argv[0]);
8685 }
8686 } else {
8687 cobglobptr->cob_main_argv0 = cob_strdup (_("unknown"));
8688 }
8689 /* The above must be last in this function as we do early return */
8690 /* from certain ifdef's */
8691 }
8692
8693 /*
8694 * Set special runtime options:
8695 * Currently this is only FILE * for trace and printer output
8696 * or to reload the runtime configuration after changing environment
8697 */
8698 void
8699 cob_set_runtime_option (enum cob_runtime_option_switch opt, void *p)
8700 {
8701 switch (opt) {
8702 case COB_SET_RUNTIME_TRACE_FILE:
8703 cobsetptr->cob_trace_file = (FILE *)p;
8704 if (p) {
8705 cobsetptr->external_trace_file = 1;
8706 } else {
8707 cobsetptr->external_trace_file = 0;
8708 }
8709 break;
8710 case COB_SET_RUNTIME_DISPLAY_PRINTER_FILE:
8711 /* note: if set cob_display_print_file is always external */
8712 cobsetptr->cob_display_print_file = (FILE *)p;
8713 break;
8714 case COB_SET_RUNTIME_DISPLAY_PUNCH_FILE:
8715 /* note: if set cob_display_punch_file is always external */
8716 if (cobsetptr->cob_display_punch_filename != NULL) {
8717 /* if previously opened by libcob: close and free pointer to filename */
8718 if (cobsetptr->cob_display_punch_file != NULL) {
8719 fclose (cobsetptr->cob_display_punch_file);
8720 }
8721 cob_free (cobsetptr->cob_display_punch_filename);
8722 cobsetptr->cob_display_punch_filename = NULL;
8723 }
8724 cobsetptr->cob_display_punch_file = (FILE *)p;
8725 break;
8726 case COB_SET_RUNTIME_DUMP_FILE:
8727 /* note: if set cob_dump_file is always external (libcob only opens it on abort)
8728 therefore we don't need to close the old one */
8729 cobsetptr->cob_dump_file = (FILE *)p;
8730 break;
8731 case COB_SET_RUNTIME_RESCAN_ENV:
8732 cob_rescan_env_vals ();
8733 break;
8734 default:
8735 cob_runtime_warning (_("%s called with unknown option: %d"),
8736 "cob_set_runtime_option", opt);
8737 }
8738 return;
8739 }
8740
8741 /*
8742 * Return current value of special runtime options
8743 */
8744 void *
8745 cob_get_runtime_option (enum cob_runtime_option_switch opt)
8746 {
8747 switch (opt) {
8748 case COB_SET_RUNTIME_TRACE_FILE:
8749 return (void*)cobsetptr->cob_trace_file;
8750 case COB_SET_RUNTIME_DISPLAY_PRINTER_FILE:
8751 return (void*)cobsetptr->cob_display_print_file;
8752 case COB_SET_RUNTIME_DISPLAY_PUNCH_FILE:
8753 /* only externalize if not aquired by libcob */
8754 if (cobsetptr->cob_display_punch_filename != NULL) {
8755 return NULL;
8756 }
8757 return (void*)cobsetptr->cob_display_punch_file;
8758 case COB_SET_RUNTIME_DUMP_FILE:
8759 return (void*)cobsetptr->cob_dump_file;
8760 default:
8761 cob_runtime_error (_("%s called with unknown option: %d"),
8762 "cob_get_runtime_option", opt);
8763 }
8764 return NULL;
8765 }
8766
8767 /* output the COBOL-view of the stacktrace to the given target,
8768 does an early exit if 'target' is NULL,
8769 'target' is FILE * */
8770 void
8771 cob_stack_trace (void *target)
8772 {
8773 if (target == NULL || !cobglobptr || !COB_MODULE_PTR) {
8774 return;
8775 }
8776 dump_trace_started |= DUMP_TRACE_ACTIVE_TRACE;
8777 cob_stack_trace_internal ((FILE *)target);
8778 dump_trace_started ^= DUMP_TRACE_ACTIVE_TRACE;
8779 }
8780
8781 /* internal output the COBOL-view of the stacktrace to the given target */
8782 void
8783 cob_stack_trace_internal (FILE *target)
8784 {
8785 cob_module *mod;
8786
8787 /* exit early in the case of no module loaded at all,
8788 possible to happen for example when aborted from cob_check_version of first module */
8789 if (!COB_MODULE_PTR
8790 || ( COB_MODULE_PTR->module_stmt == 0
8791 && COB_MODULE_PTR->next == NULL)) {
8792 return;
8793 }
8794
8795 if (target == stderr
8796 || target == stdout) {
8797 fflush (stdout);
8798 fflush (stderr);
8799 }
8800
8801 fputc ('\n', target);
8802 for (mod = COB_MODULE_PTR; mod; mod = mod->next) {
8803 if (mod->module_stmt != 0
8804 && mod->module_sources) {
8805 fprintf (target, _(" Last statement of %s was at line %d of %s"),
8806 mod->module_name,
8807 COB_GET_LINE_NUM(mod->module_stmt),
8808 mod->module_sources[COB_GET_FILE_NUM(mod->module_stmt)]);
8809 fputc ('\n', target);
8810 if (mod->next == mod) {
8811 fputs ("FIXME: recursive mod (stack trace)\n", target);
8812 break;
8813 }
8814 } else {
8815 fprintf (target, _(" Last statement of %s unknown"), mod->module_name);
8816 fputc ('\n', target);
8817 }
8818 }
8819 }
8820
8821 FILE *
8822 cob_get_dump_file (void)
8823 {
8824 #if 1 /* new version as currently only COB_DUMP_TO_FILE is used */
8825 if (cobsetptr->cob_dump_file != NULL) { /* If DUMP active, use that */
8826 return cobsetptr->cob_dump_file;
8827 } else if (cobsetptr->cob_dump_filename != NULL) { /* DUMP file defined */
8828 cobsetptr->cob_dump_file = cob_open_logfile (cobsetptr->cob_dump_filename);
8829 if (cobsetptr->cob_dump_file != NULL) {
8830 return cobsetptr->cob_dump_file;
8831 }
8832 /* could not open the file
8833 unset the filename for not referencing it later */
8834 cob_free (cobsetptr->cob_dump_filename);
8835 cobsetptr->cob_dump_filename = NULL;
8836 /* Fall-through */
8837 }
8838 if (cobsetptr->cob_trace_file != NULL) { /* If TRACE active, use that */
8839 return cobsetptr->cob_trace_file;
8840 } else {
8841 return stderr;
8842 }
8843 #else /* currently only COB_DUMP_TO_FILE used */
8844 FILE *fp;
8845 if (where == COB_DUMP_TO_FILE) {
8846 fp = cobsetptr->cob_dump_file;
8847 if (fp == NULL) {
8848 if(cobsetptr->cob_trace_file != NULL) { /* If TRACE active, use that */
8849 fp = cobsetptr->cob_trace_file;
8850 } else if(cobsetptr->cob_dump_filename != NULL) { /* Dump file defined */
8851 fp = fopen(cobsetptr->cob_dump_filename, "a");
8852 if(fp == NULL)
8853 fp = stderr;
8854 cobsetptr->cob_dump_file = fp;
8855 } else {
8856 fp = stderr;
8857 }
8858 }
8859 } else if (where == COB_DUMP_TO_PRINT) {
8860 fp = cobsetptr->cob_display_print_file;
8861 if (fp == NULL) {
8862 if(cobsetptr->cob_trace_file != NULL) { /* If TRACE active, use that */
8863 fp = cobsetptr->cob_trace_file;
8864 } else {
8865 fp = stdout;
8866 }
8867 }
8868 } else {
8869 fp = stderr;
8870 }
8871 return fp;
8872 #endif
8873 }
8874
8875 static void
8876 cob_dump_module (char *reason)
8877 {
8878 cob_module *mod;
8879 int wants_dump = 0;
8880
8881 /* Was any module compiled with -fdump? */
8882 for (mod = COB_MODULE_PTR; mod; mod = mod->next) {
8883 if (mod->flag_dump_ready) {
8884 wants_dump = 1;
8885 break;
8886 }
8887 if (mod->next == mod) {
8888 fputs ("FIXME: recursive mod (module dump)\n", stderr);
8889 break;
8890 }
8891 }
8892
8893 if (wants_dump) {
8894 FILE *fp;
8895 #if 1 /* new version as currently only COB_DUMP_TO_FILE is used */
8896 fp = cob_get_dump_file ();
8897 #else
8898 fp = cob_get_dump_file (COB_DUMP_TO_FILE);
8899 #endif
8900 if (fp != stderr) {
8901 if (reason) {
8902 if (reason[0] == 0) {
8903 reason = (char *)_ ("unknown");
8904 }
8905 fputc ('\n', fp);
8906 fprintf (fp, _("Module dump due to %s"), reason);
8907 fputc ('\n', fp);
8908 }
8909 if (fp != stdout) {
8910 /* was already sent to stderr before this function was called,
8911 so skip here for stdout/stderr ... */
8912 if (!(dump_trace_started & DUMP_TRACE_ACTIVE_TRACE)) {
8913 dump_trace_started |= DUMP_TRACE_ACTIVE_TRACE;
8914 cob_stack_trace_internal (fp);
8915 dump_trace_started ^= DUMP_TRACE_ACTIVE_TRACE;
8916 }
8917 }
8918 fflush (stdout);
8919 } else {
8920 fflush (stderr);
8921 }
8922
8923 fputc ('\n', fp);
8924 for (mod = COB_MODULE_PTR; mod; mod = mod->next) {
8925 if (mod->module_cancel.funcint) {
8926 int (*cancel_func)(const int);
8927 cancel_func = mod->module_cancel.funcint;
8928
8929 fprintf (fp, _("Dump Program-Id %s from %s compiled %s"),
8930 mod->module_name, mod->module_source, mod->module_formatted_date);
8931 fputc ('\n', fp);
8932 (void)cancel_func (-10);
8933 fputc ('\n', fp);
8934 }
8935 if (mod->next == mod) {
8936 #if 0 /* already output above */
8937 fputs ("FIXME: recursive mod (module dump)\n", stderr);
8938 #endif
8939 break;
8940 }
8941 }
8942 if (fp != stdout && fp != stderr) {
8943 char * fname = NULL;
8944 if (cobsetptr->cob_dump_filename) {
8945 fname = cobsetptr->cob_dump_filename;
8946 } else
8947 if (cobsetptr->cob_trace_file == fp
8948 && cobsetptr->cob_trace_filename != NULL
8949 && !cobsetptr->external_trace_file) {
8950 fname = cobsetptr->cob_trace_filename;
8951 }
8952 if (fname != NULL) {
8953 fputc ('\n', stderr);
8954 fprintf (stderr, _("dump written to %s"), fname);
8955 fputc ('\n', stderr);
8956 fflush (stderr);
8957 }
8958 }
8959 }
8960 }
8961
8962 #ifdef COB_DEBUG_LOG
8963 /******************************/
8964 /* Routines for COB_DEBUG_LOG */
8965 /******************************/
8966
8967 /* Check env var value and open log file */
8968 /*
8969 * Env var is COB_DEBUG_LOG
8970 * Env Var string is a series of keyword=value parameters where keywords:
8971 * L=x - options: T for trace level, W for warnings, N for normal, A for ALL
8972 * M=yy - module: RW for report writer, the 2 char code is tabled and compared
8973 * with the value coded on DEBUG_LOG("yy",("format",args));
8974 * O=path/file - file name to write log data to, default is: cob_debug_log.$$
8975 * note: replacements already done in common setting handling
8976 */
8977 void
8978 cob_debug_open (void)
8979 {
8980 char *debug_env = cobsetptr->cob_debug_log;
8981 int i, j;
8982 char module_name[4];
8983 char log_opt;
8984 char logfile[COB_SMALL_BUFF];
8985
8986 logfile[0] = 0;
8987
8988 for (i=0; debug_env[i] != 0; i++) {
8989 /* skip separator */
8990 if (debug_env[i] == ','
8991 || debug_env[i] == ';')
8992 continue;
8993
8994 /* debugging flags (not include in file name) */
8995 if (debug_env[i + 1] == '=') {
8996 log_opt = toupper (debug_env[i]);
8997 i += 2;
8998
8999 switch (log_opt) {
9000
9001 case 'M': /* module to debug */
9002 for (j = 0; j < 4; i++) {
9003 if (debug_env[i] == ','
9004 || debug_env[i] == ';'
9005 || debug_env[i] == 0) {
9006 break;
9007 }
9008 module_name[j++] = debug_env[i];
9009 }
9010 module_name[j] = 0;
9011 /* note: special module ALL is checked later */
9012 for (j = 0; j < 12 && cob_debug_modules[j][0] > ' '; j++) {
9013 if (strcasecmp (cob_debug_modules[j], module_name) == 0) {
9014 break;
9015 }
9016 }
9017 if (j < 12 && cob_debug_modules[j][0] == ' ') {
9018 strcpy (cob_debug_modules[j], module_name);
9019 }
9020 if (debug_env[i] == 0) i--;
9021 break;
9022
9023 case 'L': /* logging options */
9024 log_opt = toupper (debug_env[i]);
9025 switch (log_opt) {
9026 case 'T': /* trace */
9027 cob_debug_log_time = cob_debug_level = 3;
9028 break;
9029 case 'W': /* warnings */
9030 cob_debug_level = 2;
9031 break;
9032 case 'N': /* normal */
9033 cob_debug_level = 0;
9034 break;
9035 case 'A': /* all */
9036 cob_debug_level = 9;
9037 break;
9038 default: /* Unknown log option, just ignored for now */
9039 i--;
9040 break;
9041 }
9042 break;
9043
9044 case 'O': /* output name for logfile */
9045 for (j = 0; j < COB_SMALL_MAX; i++) {
9046 if (debug_env[i] == ','
9047 || debug_env[i] == ';'
9048 || debug_env[i] == 0) {
9049 break;
9050 }
9051 logfile[j++] = debug_env[i];
9052 }
9053 logfile[j] = 0;
9054 if (debug_env[i] == 0) i--;
9055 break;
9056
9057 default: /* Unknown x=, just ignored for now */
9058 break;
9059 }
9060 } else {
9061 /* invalid character, just ignored for now */
9062 /* note: this allows for L=WARNING (but also for L=WUMPUS) */
9063 }
9064 }
9065
9066 /* set default logfile if not given */
9067 if (logfile[0] == 0) {
9068 sprintf (logfile, "cob_debug_log.%d", cob_sys_getpid());
9069 }
9070 /* store filename for possible unlink (empty log file) */
9071 cob_debug_file_name = cob_strdup (logfile);
9072
9073 /* ensure trace file is open if we use this as debug log and exit */
9074 if (cobsetptr->cob_trace_filename &&
9075 strcmp (cobsetptr->cob_trace_filename, cob_debug_file_name) == 0) {
9076 cob_check_trace_file ();
9077 cob_debug_file = cobsetptr->cob_trace_file;
9078 return;
9079 }
9080
9081 /* open logfile */
9082 cob_debug_file = cob_open_logfile (cob_debug_file_name);
9083 if (cob_debug_file == NULL) {
9084 /* developer-only msg - not translated */
9085 cob_runtime_error ("error '%s' opening COB_DEBUG_LOG '%s', resolved from '%s'",
9086 cob_get_strerror (), cob_debug_file_name, cobsetptr->cob_debug_log);
9087 return;
9088 }
9089 }
9090
9091 /* Determine if DEBUGLOG is to be allowed */
9092 int
9093 cob_debug_logit (int level, char *module)
9094 {
9095 int i;
9096 if (cob_debug_file == NULL) {
9097 return 1;
9098 }
9099 if (level > cob_debug_level) {
9100 return 1;
9101 }
9102 for (i=0; i < 12 && cob_debug_modules[i][0] > ' '; i++) {
9103 if (strcasecmp ("ALL", cob_debug_modules[i]) == 0) {
9104 cob_debug_mod = (char*)module;
9105 return 0; /* Logging is allowed */
9106 }
9107 if (strcasecmp (module,cob_debug_modules[i]) == 0) {
9108 cob_debug_mod = (char*)&cob_debug_modules[i];
9109 return 0; /* Logging is allowed */
9110 }
9111 }
9112 return 1;
9113 }
9114
9115 /* Write logging line */
9116 static int cob_debug_hdr = 1;
9117 static unsigned int cob_debug_prv_line = 0;
9118 int
9119 cob_debug_logger (const char *fmt, ...)
9120 {
9121 va_list ap;
9122 int ln;
9123 struct cob_time time;
9124
9125 if (cob_debug_file == NULL) {
9126 return 0;
9127 }
9128 if (*fmt == '~') { /* Force line# out again to log file */
9129 fmt++;
9130 cob_debug_prv_line = -1;
9131 cob_debug_hdr = 1;
9132 }
9133 if (cob_debug_hdr) {
9134 if (cob_debug_log_time) {
9135 time = cob_get_current_date_and_time ();
9136 fprintf (cob_debug_file, "%02d:%02d:%02d.%02d ", time.hour, time.minute,
9137 time.second, time.nanosecond / 10000000);
9138 }
9139 if (cob_debug_mod) {
9140 fprintf (cob_debug_file, "%-3s:", cob_debug_mod);
9141 }
9142 if (cob_source_file) {
9143 fprintf (cob_debug_file, " %s :", cob_source_file);
9144 }
9145 if (cob_source_line && cob_source_line != cob_debug_prv_line) {
9146 fprintf (cob_debug_file, "%5d : ", cob_source_line);
9147 cob_debug_prv_line = cob_source_line;
9148 } else {
9149 fprintf (cob_debug_file, "%5s : ", " ");
9150 }
9151 cob_debug_hdr = 0;
9152 }
9153 va_start (ap, fmt);
9154 vfprintf (cob_debug_file, fmt, ap);
9155 va_end (ap);
9156 ln = strlen(fmt);
9157 if (fmt[ln-1] == '\n') {
9158 cob_debug_hdr = 1;
9159 fflush (cob_debug_file);
9160 }
9161 return 0;
9162 }
9163
9164 static int /* Return TRUE if word is repeated 16 times */
9165 repeatWord(
9166 char *match, /* 4 bytes to match */
9167 char *mem) /* Memory area to match repeated value */
9168 {
9169 if(memcmp(match, &mem[0], 4) == 0
9170 && memcmp(match, &mem[4], 4) == 0
9171 && memcmp(match, &mem[8], 4) == 0
9172 && memcmp(match, &mem[12], 4) == 0)
9173 return 1;
9174 return 0;
9175 }
9176
9177 /* Hexdump of memory */
9178 int
9179 cob_debug_dump (void *pMem, int len)
9180 {
9181 #define dMaxPerLine 24
9182 #define dMaxHex ((dMaxPerLine*2)+(dMaxPerLine/4-1))
9183 register int i, j, k;
9184 register char c, *mem = pMem;
9185 char lastWord[4];
9186 char hex[dMaxHex+4],chr[dMaxPerLine+4];
9187 int adrs = 0;
9188
9189 if (cob_debug_file == NULL)
9190 return 0;
9191 memset (lastWord,0xFD, 4);
9192 for (i=0; i < len; ) {
9193 for (j=k=0; j < dMaxPerLine && (i+j) < len; j++) {
9194 k += sprintf(&hex[k],"%02X",mem[i+j]&0xFF);
9195 if ((j % 4) == 3 )
9196 hex[k++] = ' ';
9197 }
9198 if (k && hex[k-1] == ' ')
9199 hex[k-1] = 0;
9200 hex[k] = 0;
9201
9202 k = 0;
9203 for (j=0; j<dMaxPerLine && (i+j)<len; j++) {
9204 c = mem[i+j];
9205 chr[k++] = c >= ' ' && c < 0x7f ? c : '.';
9206 }
9207 chr[k++] = 0;
9208
9209 fprintf (cob_debug_file," %6.6X : %-*s '%s'\n",adrs+i,dMaxHex,hex,chr);
9210 if ((i + dMaxPerLine) < len )
9211 memcpy( (char *)lastWord, (char *)&mem[i+dMaxPerLine-4], j<4?j:4);
9212 i += dMaxPerLine;
9213 if( (i + (16*2)) < len
9214 && repeatWord (lastWord, &mem[i])
9215 && repeatWord (lastWord, &mem[i+dMaxPerLine])) {
9216 fprintf (cob_debug_file," %6.6X : ",adrs+i);
9217 while (i < len - 16
9218 && repeatWord(lastWord,&mem[i]))
9219 i += 16;
9220 fprintf (cob_debug_file," thru %6.6X same as last word\n",adrs+i-1);
9221 }
9222 }
9223 fflush (cob_debug_file);
9224
9225 return 0;
9226 }
9227 #endif
9228