1 /*
2 Copyright (C) 2003-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
22 #include <config.h>
23
24 #ifndef _GNU_SOURCE
25 #define _GNU_SOURCE 1
26 #endif
27
28 #include <stdio.h>
29 #include <stdlib.h>
30 #include <stddef.h>
31 #include <stdarg.h>
32 #include <string.h>
33 #include <ctype.h>
34 #include <sys/types.h>
35 #include <sys/stat.h>
36 #ifdef HAVE_UNISTD_H
37 #include <unistd.h>
38 #endif
39
40 #ifdef HAVE_FMEMOPEN
41 #if defined(HAVE_DECL_FMEMOPEN) && HAVE_DECL_FMEMOPEN == 0
42 /* function available and working, declaration missing on AIX... */
43 FILE *fmemopen (void *buf, size_t size, const char *mode);
44 #endif
45 #endif
46
47 #include <errno.h>
48
49 /* NOTE - The following variable should be uncommented when
50 it is known that dlopen(NULL) is borked.
51 This is known to be true for some PA-RISC HP-UX 11.11 systems.
52 This is fixed with HP patch PHSS_28871. (There are newer but this
53 fixes dlopen/dlsym problems)
54 */
55 /* #define COB_BORKED_DLOPEN */
56
57 #ifdef _WIN32
58
59 #define WIN32_LEAN_AND_MEAN
60 #include <windows.h>
61 #include <io.h> /* for access */
62
63 static HMODULE
lt_dlopen(const char * x)64 lt_dlopen (const char *x)
65 {
66 if (x == NULL) {
67 return GetModuleHandle (NULL);
68 }
69 return LoadLibrary(x);
70 }
71
72 static void *
lt_dlsym(HMODULE hmod,const char * p)73 lt_dlsym (HMODULE hmod, const char *p)
74 {
75 union {
76 FARPROC modaddr;
77 void *voidptr;
78 } modun;
79
80 modun.modaddr = GetProcAddress(hmod, p);
81 return modun.voidptr;
82 }
83
84 #define lt_dlclose(x) FreeLibrary(x)
85 #define lt_dlinit()
86 #define lt_dlexit()
87 #define lt_dlhandle HMODULE
88
89 #if 0 /* RXWRXW - dlerror */
90 static char errbuf[64];
91 static char *
92 lt_dlerror (void)
93 {
94 sprintf(errbuf, _("LoadLibrary/GetProcAddress error %d"), (int)GetLastError());
95 return errbuf;
96 }
97 #endif
98
99 #elif defined(USE_LIBDL)
100
101 #include <dlfcn.h>
102
103 #define lt_dlopen(x) dlopen(x, RTLD_LAZY | RTLD_GLOBAL)
104 #define lt_dlsym(x,y) dlsym(x, y)
105 #define lt_dlclose(x) dlclose(x)
106 #define lt_dlerror() dlerror()
107 #define lt_dlinit()
108 #define lt_dlexit()
109 #define lt_dlhandle void *
110
111 #else
112
113 #include <ltdl.h>
114
115 #endif
116
117 /* Force symbol exports */
118 #define COB_LIB_EXPIMP
119 #include "libcob.h"
120 #include "coblocal.h"
121
122 #define COB_MAX_COBCALL_PARMS 16
123 #define CALL_BUFF_SIZE 256U
124 #define CALL_BUFF_MAX (CALL_BUFF_SIZE - 1U)
125
126 #define HASH_SIZE 131U
127
128 /* Call table */
129 #if 0 /* Alternative hash structure */
130 #define COB_ALT_HASH
131 #endif
132
133 struct call_hash {
134 struct call_hash *next; /* Linked list next pointer */
135 const char *name; /* Original called name */
136 void *func; /* Function address */
137 cob_module *module; /* Program module structure */
138 lt_dlhandle handle; /* Handle to loaded module */
139 const char *path; /* Full path of module */
140 unsigned int no_phys_cancel; /* No physical cancel */
141 };
142
143 struct struct_handle {
144 struct struct_handle *next; /* Linked list next pointer */
145 const char *path; /* Path of module */
146 lt_dlhandle handle; /* Handle to loaded module */
147 };
148
149 struct system_table {
150 const char *syst_name;
151 cob_call_union syst_call;
152 };
153
154 /* Local variables */
155
156 #ifdef COB_ALT_HASH
157 static struct call_hash *call_table;
158 #else
159 static struct call_hash **call_table;
160 #endif
161
162 static struct struct_handle *base_preload_ptr;
163 static struct struct_handle *base_dynload_ptr;
164
165 static cob_global *cobglobptr = NULL;
166 static cob_settings *cobsetptr = NULL;
167
168 static char **resolve_path;
169 static char *resolve_error;
170 static char *resolve_alloc;
171 static char *resolve_error_buff;
172 static void *call_buffer;
173 static char *call_filename_buff;
174
175 #ifndef COB_BORKED_DLOPEN
176 static lt_dlhandle mainhandle;
177 #endif
178
179 static size_t call_lastsize;
180 static size_t resolve_size = 0;
181 static unsigned int cob_jmp_primed;
182 static cob_field_attr const_float_attr =
183 {COB_TYPE_NUMERIC_DOUBLE, 8, 0, COB_FLAG_HAVE_SIGN, NULL};
184 static cob_field_attr const_binll_attr =
185 {COB_TYPE_NUMERIC_BINARY, 18, 0, COB_FLAG_HAVE_SIGN, NULL};
186 static cob_field_attr const_binull_attr =
187 {COB_TYPE_NUMERIC_BINARY, 18, 0, 0, NULL};
188
189 #undef COB_SYSTEM_GEN
190 #define COB_SYSTEM_GEN(cob_name, pmin, pmax, c_name) \
191 { cob_name, {(void *(*)(void *))c_name} },
192
193 static const struct system_table system_tab[] = {
194 #include "system.def"
195 { NULL, {NULL} }
196 };
197 #undef COB_SYSTEM_GEN
198
199 static const unsigned char hexval[] = "0123456789ABCDEF";
200
201 #ifdef HAVE_DESIGNATED_INITS
202 static const unsigned char valid_char[256] = {
203 ['0'] = 1,
204 ['1'] = 1,
205 ['2'] = 1,
206 ['3'] = 1,
207 ['4'] = 1,
208 ['5'] = 1,
209 ['6'] = 1,
210 ['7'] = 1,
211 ['8'] = 1,
212 ['9'] = 1,
213 ['A'] = 1,
214 ['B'] = 1,
215 ['C'] = 1,
216 ['D'] = 1,
217 ['E'] = 1,
218 ['F'] = 1,
219 ['G'] = 1,
220 ['H'] = 1,
221 ['I'] = 1,
222 ['J'] = 1,
223 ['K'] = 1,
224 ['L'] = 1,
225 ['M'] = 1,
226 ['N'] = 1,
227 ['O'] = 1,
228 ['P'] = 1,
229 ['Q'] = 1,
230 ['R'] = 1,
231 ['S'] = 1,
232 ['T'] = 1,
233 ['U'] = 1,
234 ['V'] = 1,
235 ['W'] = 1,
236 ['X'] = 1,
237 ['Y'] = 1,
238 ['Z'] = 1,
239 ['_'] = 1,
240 ['a'] = 1,
241 ['b'] = 1,
242 ['c'] = 1,
243 ['d'] = 1,
244 ['e'] = 1,
245 ['f'] = 1,
246 ['g'] = 1,
247 ['h'] = 1,
248 ['i'] = 1,
249 ['j'] = 1,
250 ['k'] = 1,
251 ['l'] = 1,
252 ['m'] = 1,
253 ['n'] = 1,
254 ['o'] = 1,
255 ['p'] = 1,
256 ['q'] = 1,
257 ['r'] = 1,
258 ['s'] = 1,
259 ['t'] = 1,
260 ['u'] = 1,
261 ['v'] = 1,
262 ['w'] = 1,
263 ['x'] = 1,
264 ['y'] = 1,
265 ['z'] = 1
266 };
267 #else
268 static int init_valid_char = 1;
269 static unsigned char valid_char[256];
270 static const unsigned char pvalid_char[] =
271 "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ_abcdefghijklmnopqrstuvwxyz";
272 #endif
273
274 /* Local functions */
275
276 static void
set_resolve_error(void)277 set_resolve_error (void)
278 {
279 resolve_error = resolve_error_buff;
280 cob_set_exception (COB_EC_PROGRAM_NOT_FOUND);
281 }
282
last_entry_is_working_directory(const char * buff,const char * pstr)283 static int last_entry_is_working_directory (const char *buff, const char *pstr)
284 {
285 const size_t pos = pstr - buff; /* always > 2 */
286 if (buff[pos - 1] == '.'
287 && buff[pos - 2] == PATHSEP_CHAR) {
288 return 1;
289 }
290 return 0;
291 }
292
293 /* resolves the actual library path used from
294 * COB_LIBRARY_PATH runtime setting
295 * "." as current working direktory [if not included already: prefixed]
296 * COB_LIBRARY_PATH inbuilt (which normally includes modules
297 like CBL_OC_DUMP) [if not included already: appended]
298 */
299 static void
cob_set_library_path()300 cob_set_library_path ()
301 {
302 char buff[COB_MEDIUM_BUFF];
303 char *p;
304 char *pstr;
305 size_t i;
306 struct stat st;
307
308 int flag;
309
310 /* Clear the previous path */
311 if (resolve_path) {
312 cob_free (resolve_path);
313 cob_free (resolve_alloc);
314 }
315
316 /* setup buffer and count number of separators,
317 check for "." */
318 i = 1;
319 pstr = buff + 2; /* leaving place for prefixing the working directory */
320 buff[0] = ' ';
321 buff[1] = PATHSEP_CHAR;
322 flag = 0;
323 if (cobsetptr->cob_library_path != NULL
324 && strcmp (cobsetptr->cob_library_path, ".") != 0) {
325 for (p = cobsetptr->cob_library_path; *p; p++, pstr++) {
326 #ifdef _WIN32
327 if (*p == '/') {
328 *pstr = '\\';
329 continue;
330 }
331 #else
332 if (*p == '\\') {
333 *pstr = '/';
334 continue;
335 }
336 #endif
337 if (*p == PATHSEP_CHAR) {
338 i++;
339 flag |= last_entry_is_working_directory (buff, pstr);
340 }
341 *pstr = *p;
342 }
343 *pstr = PATHSEP_CHAR;
344 i++;
345 flag |= last_entry_is_working_directory (buff, pstr);
346 pstr++;
347 }
348
349 #ifdef COB_LIBRARY_PATH
350 if (COB_LIBRARY_PATH[0] != 0
351 && strcmp (COB_LIBRARY_PATH, ".") != 0) {
352 for (p = (char *)COB_LIBRARY_PATH; *p; p++, pstr++) {
353 #ifdef _WIN32
354 if (*p == '/') {
355 *pstr = '\\';
356 continue;
357 }
358 #else
359 if (*p == '\\') {
360 *pstr = '/';
361 continue;
362 }
363 #endif
364 if (*p == PATHSEP_CHAR) {
365 i++;
366 }
367 *pstr = *p;
368 }
369 }
370 #endif
371 *pstr = 0;
372
373 /* prefix working directory if missing */
374 if (!flag) {
375 buff[0] = '.';
376 i++;
377 p = buff;
378 } else {
379 p = buff + 2;
380 }
381 /* Build path array */
382 resolve_alloc = cob_strdup (p);
383 pstr = resolve_alloc;
384
385 resolve_path = cob_malloc (sizeof (char *) * i);
386 resolve_size = 0;
387
388 for (; ; ) {
389 p = strtok (pstr, PATHSEP_STR);
390 if (!p) {
391 break;
392 }
393 pstr = NULL;
394
395 /* check if directory
396 (note: entries like X:\ _must_ be specified with trailing slash !) */
397 if (stat (p, &st) || !(S_ISDIR (st.st_mode))) {
398 /* possibly raise a warning, maybe only if explicit asked */
399 continue;
400 }
401
402 /* remove trailing slash from entry (always added on use) */
403 i = strlen (p) - 1;
404 if (p[i] == SLASH_CHAR) {
405 p[i] = 0;
406 }
407
408 /* check if we have this path already */
409 flag = 0;
410 for (i = 0; i < resolve_size; i++) {
411 if (strcmp (resolve_path[i], p) == 0) {
412 flag = 1;
413 break;
414 }
415 }
416
417 /* finally: new entry for the resolve path */
418 if (flag == 0) {
419 resolve_path[resolve_size++] = p;
420 }
421 }
422 }
423
424 static void
do_cancel_module(struct call_hash * p,struct call_hash ** base_hash,struct call_hash * prev)425 do_cancel_module (struct call_hash *p, struct call_hash **base_hash,
426 struct call_hash *prev)
427 {
428 struct struct_handle *dynptr;
429 int (*cancel_func)(const int, void *, void *, void *, void *);
430 int nocancel;
431 nocancel = 0;
432
433 /* FIXME: check the modules entry point and take care of
434 CBL_ERROR_PROC / CBL_EXIT_PROC which defines: If a program containing
435 an exit/error procedure is canceled, the exit/error procedure is removed. */
436
437 if (!p->module) {
438 return;
439 }
440 if (!p->module->module_cancel.funcvoid) {
441 return;
442 }
443 if (p->module->flag_no_phys_canc) {
444 nocancel = 1;
445 }
446 /* This should be impossible */
447 /* LCOV_EXCL_START */
448 if (p->module->module_active) {
449 nocancel = 1;
450 }
451 /* LCOV_EXCL_STOP */
452 if (p->module->module_ref_count &&
453 *(p->module->module_ref_count)) {
454 nocancel = 1;
455 }
456 #ifdef _MSC_VER
457 #pragma warning(suppress: 4113) /* funcint is a generic function prototype */
458 cancel_func = p->module->module_cancel.funcint;
459 #else
460 cancel_func = p->module->module_cancel.funcint;
461 #endif
462 (void)cancel_func (-1, NULL, NULL, NULL, NULL);
463 p->module = NULL;
464
465 if (nocancel) {
466 return;
467 }
468 if (!cobsetptr->cob_physical_cancel) {
469 return;
470 }
471 if (p->no_phys_cancel) {
472 return;
473 }
474 if (!p->handle) {
475 return;
476 }
477
478 lt_dlclose (p->handle);
479
480 dynptr = base_dynload_ptr;
481 for (; dynptr; dynptr = dynptr->next) {
482 if (dynptr->handle == p->handle) {
483 dynptr->handle = NULL;
484 }
485 }
486
487 if (!prev) {
488 *base_hash = p->next;
489 } else {
490 prev->next = p->next;
491 }
492 if (p->name) {
493 cob_free ((void *)(p->name));
494 }
495 if (p->path) {
496 cob_free ((void *)(p->path));
497 }
498 cob_free (p);
499 }
500
501 static void *
cob_get_buff(const size_t buffsize)502 cob_get_buff (const size_t buffsize)
503 {
504 if (buffsize > call_lastsize) {
505 call_lastsize = buffsize;
506 cob_free (call_buffer);
507 call_buffer = cob_fast_malloc (buffsize);
508 }
509 return call_buffer;
510 }
511
512 static void
cache_dynload(const char * path,lt_dlhandle handle)513 cache_dynload (const char *path, lt_dlhandle handle)
514 {
515 struct struct_handle *dynptr;
516
517 for (dynptr = base_dynload_ptr; dynptr; dynptr = dynptr->next) {
518 if (!strcmp (path, dynptr->path)) {
519 if (!dynptr->handle) {
520 dynptr->handle = handle;
521 return;
522 }
523 }
524 }
525 dynptr = cob_malloc (sizeof (struct struct_handle));
526 dynptr->path = cob_strdup (path);
527 dynptr->handle = handle;
528 dynptr->next = base_dynload_ptr;
529 base_dynload_ptr = dynptr;
530 }
531
532 static size_t
cache_preload(const char * path)533 cache_preload (const char *path)
534 {
535 struct struct_handle *preptr;
536 lt_dlhandle libhandle;
537 #if defined(_WIN32) || defined(__CYGWIN__)
538 struct struct_handle *last_elem = NULL;
539 #endif
540
541 /* Check for duplicate */
542 for (preptr = base_preload_ptr; preptr; preptr = preptr->next) {
543 if (!strcmp (path, preptr->path)) {
544 return 1;
545 }
546 #if defined(_WIN32) || defined(__CYGWIN__)
547 /* Save last element of preload list */
548 if (!preptr->next) last_elem = preptr;
549 #endif
550 }
551
552 if (access (path, R_OK) != 0) {
553 return 0;
554 }
555
556 libhandle = lt_dlopen (path);
557 if (!libhandle) {
558 return 0;
559 }
560
561 preptr = cob_malloc (sizeof (struct struct_handle));
562 preptr->path = cob_strdup (path);
563 preptr->handle = libhandle;
564
565 #if defined(_WIN32) || defined(__CYGWIN__)
566 /*
567 * Observation: dlopen (POSIX) and lt_dlopen (UNIX) are overloading
568 * symbols with equal name. So if we load two libraries with equal
569 * named symbols, the last one wins and is loaded.
570 * LoadLibrary (Win32) ignores any equal named symbol
571 * if another library with this symbol was already loaded.
572 *
573 * In Windows (including MinGW/CYGWIN) we need to load modules
574 * in the same order as we save them to COB_PRE_LOAD due to issues
575 * if we have got two modules with equal entry points.
576 */
577 if (last_elem) {
578 last_elem->next = preptr;
579 } else {
580 preptr->next = NULL;
581 base_preload_ptr = preptr;
582 }
583 #else
584 preptr->next = base_preload_ptr;
585 base_preload_ptr = preptr;
586 #endif
587
588
589 if (!cobsetptr->cob_preload_str) {
590 cobsetptr->cob_preload_str = cob_strdup(path);
591 } else {
592 cobsetptr->cob_preload_str = cob_strcat((char*) PATHSEP_STR, cobsetptr->cob_preload_str, 2);
593 cobsetptr->cob_preload_str = cob_strcat((char*) path, cobsetptr->cob_preload_str, 2);
594 }
595
596 return 1;
597 }
598
599 #ifndef COB_ALT_HASH
600 static COB_INLINE unsigned int
hash(const unsigned char * s)601 hash (const unsigned char *s)
602 {
603 unsigned int val = 0;
604
605 while (*s) {
606 val += *s++;
607 }
608 return val % HASH_SIZE;
609 }
610 #endif
611
612 static void
insert(const char * name,void * func,lt_dlhandle handle,cob_module * module,const char * path,const unsigned int nocanc)613 insert (const char *name, void *func, lt_dlhandle handle,
614 cob_module *module, const char *path,
615 const unsigned int nocanc)
616 {
617 struct call_hash *p;
618 #ifndef COB_ALT_HASH
619 unsigned int val;
620 #endif
621
622 p = cob_malloc (sizeof (struct call_hash));
623 p->name = cob_strdup (name);
624 p->func = func;
625 p->handle = handle;
626 p->module = module;
627 if (path) {
628 #if defined(HAVE_CANONICALIZE_FILE_NAME)
629 /* Malloced path or NULL */
630 p->path = canonicalize_file_name (path);
631 #elif defined(HAVE_REALPATH)
632 char *s;
633
634 s = cob_malloc ((size_t)COB_NORMAL_BUFF);
635 if (realpath (path, s) != NULL) {
636 p->path = cob_strdup (s);
637 }
638 cob_free (s);
639 #elif defined (_WIN32)
640 /* Malloced path or NULL */
641 p->path = _fullpath (NULL, path, 1);
642 #endif
643 if (!p->path) {
644 p->path = cob_strdup (path);
645 }
646 }
647 p->no_phys_cancel = nocanc;
648 #ifdef COB_ALT_HASH
649 p->next = call_table;
650 call_table = p;
651 #else
652 val = hash ((const unsigned char *)name);
653 p->next = call_table[val];
654 call_table[val] = p;
655 #endif
656 }
657
658 static void *
lookup(const char * name)659 lookup (const char *name)
660 {
661 struct call_hash *p;
662
663 #ifdef COB_ALT_HASH
664 p = call_table;
665 #else
666 p = call_table[hash ((const unsigned char *)name)];
667 #endif
668 for (; p; p = p->next) {
669 if (strcmp (name, p->name) == 0) {
670 return p->func;
671 }
672 }
673 return NULL;
674 }
675
676 static int
cob_encode_invalid_chars(const unsigned char * const name,unsigned char * const name_buff,const int buff_size,int * external_pos)677 cob_encode_invalid_chars (const unsigned char* const name,
678 unsigned char* const name_buff,
679 const int buff_size, int *external_pos)
680 {
681 const unsigned char *s = name;
682 int pos = *external_pos;
683
684 #ifndef HAVE_DESIGNATED_INITS
685 if (init_valid_char) {
686 const unsigned char *pv;
687 init_valid_char = 0;
688 memset (valid_char, 0, sizeof(valid_char));
689 for (pv = pvalid_char; *pv; ++pv) {
690 valid_char[*pv] = 1;
691 }
692 }
693 #endif
694
695 /* Encode invalid letters */
696 for (; *s; ++s) {
697 if (pos >= buff_size - 3) {
698 name_buff[pos] = 0;
699 return -pos;
700 }
701 if (likely (valid_char[*s])) {
702 name_buff[pos++] = *s;
703 } else {
704 name_buff[pos++] = (unsigned char)'_';
705 if (*s == (unsigned char)'-') {
706 name_buff[pos++] = (unsigned char)'_';
707 } else {
708 name_buff[pos++] = hexval[*s / 16U];
709 name_buff[pos++] = hexval[*s % 16U];
710 }
711 }
712 }
713
714 *external_pos = pos;
715 return pos;
716 }
717
718 /** encode given name
719 \param name to encode
720 \param name_buff to place the encoded name to
721 \param buff_size available
722 \param fold_case may be COB_FOLD_UPPER or COB_FOLD_LOWER
723 \return size of the encoded name, negative if the buffer size would be exceeded
724 */
725 int
cob_encode_program_id(const unsigned char * const name,unsigned char * const name_buff,const int buff_size,const int fold_case)726 cob_encode_program_id (const unsigned char *const name,
727 unsigned char *const name_buff,
728 const int buff_size, const int fold_case)
729 {
730 int pos = 0;
731 /* Encode the initial digit */
732 if (unlikely (*name <= (unsigned char)'9' && *name >= (unsigned char)'0')) {
733 name_buff[pos++] = (unsigned char)'_';
734 }
735 /* Encode invalid letters */
736 cob_encode_invalid_chars (name, name_buff, buff_size, &pos);
737
738 name_buff[pos] = 0;
739
740 /* Check case folding */
741 switch (fold_case) {
742 case COB_FOLD_NONE:
743 break;
744 case COB_FOLD_UPPER:
745 {
746 unsigned char *p;
747 for (p = name_buff; *p; p++) {
748 if (islower (*p)) {
749 *p = (cob_u8_t)toupper (*p);
750 }
751 }
752 break;
753 }
754 case COB_FOLD_LOWER:
755 {
756 unsigned char *p;
757 for (p = name_buff; *p; p++) {
758 if (isupper (*p)) {
759 *p = (cob_u8_t)tolower (*p);
760 }
761 }
762 break;
763 }
764 default:
765 break;
766 }
767
768 return pos;
769 }
770
771 static void *
cob_resolve_internal(const char * name,const char * dirent,const int fold_case)772 cob_resolve_internal (const char *name, const char *dirent,
773 const int fold_case)
774 {
775 const unsigned char *s;
776 void *func;
777 struct struct_handle *preptr;
778 lt_dlhandle handle;
779 size_t i;
780 char call_entry_buff[COB_MINI_BUFF];
781
782 /* LCOV_EXCL_START */
783 if (unlikely(!cobglobptr)) {
784 cob_fatal_error (COB_FERROR_INITIALIZED);
785 }
786 /* LCOV_EXCL_STOP */
787 cobglobptr->cob_exception_code = 0;
788
789 /* Search the cache */
790 func = lookup (name);
791 if (func) {
792 return func;
793 }
794
795 s = (const unsigned char *)name;
796
797 /* Encode program name, including case folding */
798 cob_encode_program_id (s, (unsigned char *)call_entry_buff,
799 COB_MINI_MAX, fold_case);
800
801 #ifndef COB_BORKED_DLOPEN
802 /* Search the main program */
803 if (mainhandle != NULL) {
804 func = lt_dlsym (mainhandle, call_entry_buff);
805 if (func != NULL) {
806 insert (name, func, mainhandle, NULL, NULL, 1);
807 resolve_error = NULL;
808 return func;
809 }
810 }
811 #endif
812
813 /* Search preloaded modules */
814 for (preptr = base_preload_ptr; preptr; preptr = preptr->next) {
815 func = lt_dlsym (preptr->handle, call_entry_buff);
816 if (func != NULL) {
817 insert (name, func, preptr->handle, NULL, preptr->path, 1);
818 resolve_error = NULL;
819 return func;
820 }
821 }
822
823 /* Search dynamic modules */
824 for (preptr = base_dynload_ptr; preptr; preptr = preptr->next) {
825 if (!preptr->handle) {
826 continue;
827 }
828 func = lt_dlsym (preptr->handle, call_entry_buff);
829 if (func != NULL) {
830 insert (name, func, preptr->handle,
831 NULL, preptr->path, 1);
832 resolve_error = NULL;
833 return func;
834 }
835 }
836
837 #if 0 /* RXWRXW RTLD */
838 #if defined(USE_LIBDL) && defined (RTLD_DEFAULT)
839 func = lt_dlsym (RTLD_DEFAULT, call_entry_buff);
840 if (func != NULL) {
841 insert (name, func, NULL, NULL, NULL, 1);
842 resolve_error = NULL;
843 return func;
844 }
845 #endif
846 #endif
847
848 s = (const unsigned char *)name;
849
850 /* Check if name needs conversion */
851 if (unlikely(cobsetptr->name_convert != 0)) {
852 unsigned char call_entry2_buff[COB_MINI_BUFF];
853 unsigned char *p = call_entry2_buff;
854 for (; *s; ++s, ++p) {
855 if (cobsetptr->name_convert == 1 && isupper (*s)) {
856 *p = (cob_u8_t) tolower (*s);
857 } else if (cobsetptr->name_convert == 2 && islower (*s)) {
858 *p = (cob_u8_t) toupper (*s);
859 } else {
860 *p = *s;
861 }
862 }
863 *p = 0;
864 s = call_entry2_buff;
865 }
866
867 /* Search external modules */
868 resolve_error_buff[CALL_BUFF_MAX] = 0;
869 #ifdef __OS400__
870 strcpy (call_filename_buff, s);
871 for (p = call_filename_buff; *p; ++p) {
872 *p = (cob_u8_t)toupper(*p);
873 }
874 handle = lt_dlopen (call_filename_buff);
875 if (handle != NULL) {
876 /* Candidate for future calls */
877 cache_dynload (call_filename_buff, handle);
878 func = lt_dlsym (handle, call_entry_buff);
879 if (func != NULL) {
880 insert (name, func, handle, NULL, call_filename_buff, 0);
881 resolve_error = NULL;
882 return func;
883 }
884 }
885 #else
886 if (dirent) {
887 snprintf (call_filename_buff, (size_t)COB_NORMAL_MAX,
888 "%s%s.%s", dirent, (char *)s, COB_MODULE_EXT);
889 call_filename_buff[COB_NORMAL_MAX] = 0;
890 if (access (call_filename_buff, R_OK) != 0) {
891 snprintf (resolve_error_buff, (size_t)CALL_BUFF_MAX,
892 "module '%s' not found", name);
893 set_resolve_error ();
894 return NULL;
895 }
896 handle = lt_dlopen (call_filename_buff);
897 if (handle != NULL) {
898 /* Candidate for future calls */
899 cache_dynload (call_filename_buff, handle);
900 func = lt_dlsym (handle, call_entry_buff);
901 if (func != NULL) {
902 insert (name, func, handle, NULL,
903 call_filename_buff, 0);
904 resolve_error = NULL;
905 return func;
906 }
907 }
908 snprintf (resolve_error_buff, (size_t)CALL_BUFF_MAX,
909 "entry point '%s' not found", (const char *)s);
910 set_resolve_error ();
911 return NULL;
912 }
913 for (i = 0; i < resolve_size; ++i) {
914 call_filename_buff[COB_NORMAL_MAX] = 0;
915 if (resolve_path[i] == NULL) {
916 snprintf (call_filename_buff, (size_t)COB_NORMAL_MAX,
917 "%s.%s", (char *)s, COB_MODULE_EXT);
918 } else {
919 snprintf (call_filename_buff, (size_t)COB_NORMAL_MAX,
920 "%s%c%s.%s", resolve_path[i],
921 SLASH_CHAR, (char *)s, COB_MODULE_EXT);
922 }
923 call_filename_buff[COB_NORMAL_MAX] = 0;
924 if (access (call_filename_buff, R_OK) == 0) {
925 handle = lt_dlopen (call_filename_buff);
926 if (handle != NULL) {
927 /* Candidate for future calls */
928 cache_dynload (call_filename_buff, handle);
929 func = lt_dlsym (handle, call_entry_buff);
930 if (func != NULL) {
931 insert (name, func, handle, NULL,
932 call_filename_buff, 0);
933 resolve_error = NULL;
934 return func;
935 }
936 }
937 snprintf (resolve_error_buff, (size_t)CALL_BUFF_MAX,
938 "entry point '%s' not found", (const char *)s);
939 set_resolve_error ();
940 return NULL;
941 }
942 }
943 #endif
944 snprintf (resolve_error_buff, (size_t)CALL_BUFF_MAX,
945 "module '%s' not found", name);
946 set_resolve_error ();
947 return NULL;
948 }
949
950 static const char *
cob_chk_dirp(const char * name)951 cob_chk_dirp (const char *name)
952 {
953 const char *p;
954 const char *q;
955
956 q = NULL;
957 for (p = name; *p; p++) {
958 if (*p == '/' || *p == '\\') {
959 q = p + 1;
960 }
961 }
962 if (q) {
963 return q;
964 }
965 return name;
966 }
967
968 static char *
cob_chk_call_path(const char * name,char ** dirent)969 cob_chk_call_path (const char *name, char **dirent)
970 {
971 char *p;
972 char *q;
973 size_t size1;
974 size_t size2;
975
976 *dirent = NULL;
977 q = NULL;
978 size2 = 0;
979 for (p = (char *)name, size1 = 0; *p; p++, size1++) {
980 if (*p == '/' || *p == '\\') {
981 q = p + 1;
982 size2 = size1 + 1;
983 }
984 }
985 if (q) {
986 p = cob_strdup (name);
987 p[size2] = 0;
988 *dirent = p;
989 for (; *p; p++) {
990 #ifdef _WIN32
991 if (*p == '/') {
992 *p = '\\';
993 }
994 #else
995 if (*p == '\\') {
996 *p = '/';
997 }
998 #endif
999 }
1000 return q;
1001 }
1002 return (char *)name;
1003 }
1004
1005 /* Global functions */
1006
1007 const char *
cob_resolve_error(void)1008 cob_resolve_error (void)
1009 {
1010 const char *p;
1011
1012 if (!resolve_error) {
1013 p = _("indeterminable error in resolve of COBOL CALL");
1014 } else {
1015 p = resolve_error;
1016 resolve_error = NULL;
1017 }
1018 return p;
1019 }
1020
1021 void
cob_call_error(void)1022 cob_call_error (void)
1023 {
1024 cob_runtime_error ("%s", cob_resolve_error ());
1025 cob_stop_run (EXIT_FAILURE);
1026 }
1027
1028 void
cob_set_cancel(cob_module * m)1029 cob_set_cancel (cob_module *m)
1030 {
1031 struct call_hash *p;
1032
1033 #ifdef COB_ALT_HASH
1034 p = call_table;
1035 #else
1036 p = call_table[hash ((const unsigned char *)(m->module_name))];
1037 #endif
1038 for (; p; p = p->next) {
1039 if (strcmp (m->module_name, p->name) == 0) {
1040 p->module = m;
1041 /* Set path in program module structure */
1042 if (p->path && m->module_path && !*(m->module_path)) {
1043 *(m->module_path) = p->path;
1044 }
1045 return;
1046 }
1047 }
1048 insert (m->module_name, m->module_entry.funcvoid, NULL, m, NULL, 1);
1049 }
1050
1051 void *
cob_resolve(const char * name)1052 cob_resolve (const char *name)
1053 {
1054 void *p;
1055 char *entry;
1056 char *dirent;
1057
1058 entry = cob_chk_call_path (name, &dirent);
1059 p = cob_resolve_internal (entry, dirent, 0);
1060 if (dirent) {
1061 cob_free (dirent);
1062 }
1063 return p;
1064 }
1065
1066 void *
cob_resolve_cobol(const char * name,const int fold_case,const int errind)1067 cob_resolve_cobol (const char *name, const int fold_case, const int errind)
1068 {
1069 void *p;
1070 char *entry;
1071 char *dirent;
1072
1073 entry = cob_chk_call_path (name, &dirent);
1074 p = cob_resolve_internal (entry, dirent, fold_case);
1075 if (dirent) {
1076 cob_free (dirent);
1077 }
1078 if (unlikely(!p)) {
1079 if (errind) {
1080 cob_call_error ();
1081 }
1082 cob_set_exception (COB_EC_PROGRAM_NOT_FOUND);
1083 }
1084 return p;
1085 }
1086
1087 void *
cob_resolve_func(const char * name)1088 cob_resolve_func (const char *name)
1089 {
1090 void *p;
1091
1092 p = cob_resolve_internal (name, NULL, 0);
1093 if (unlikely(!p)) {
1094 cob_runtime_error (_("user-defined FUNCTION '%s' not found"), name);
1095 cob_stop_run (EXIT_FAILURE);
1096 }
1097 return p;
1098 }
1099
1100 void *
cob_call_field(const cob_field * f,const struct cob_call_struct * cs,const unsigned int errind,const int fold_case)1101 cob_call_field (const cob_field *f, const struct cob_call_struct *cs,
1102 const unsigned int errind, const int fold_case)
1103 {
1104 void *p;
1105 const struct cob_call_struct *s;
1106 const struct system_table *psyst;
1107 char *buff;
1108 char *entry;
1109 char *dirent;
1110
1111 /* LCOV_EXCL_START */
1112 if (unlikely(!cobglobptr)) {
1113 cob_fatal_error (COB_FERROR_INITIALIZED);
1114 }
1115 /* LCOV_EXCL_STOP */
1116
1117 buff = cob_get_buff (f->size + 1);
1118 cob_field_to_string (f, buff, f->size);
1119
1120 /* check for uncommon leading space - trim it */
1121 if (*buff == ' ') {
1122 size_t len;
1123 /* same warning as in cobc/typeck.c */
1124 cob_runtime_warning (
1125 _("'%s' literal includes leading spaces which are omitted"), buff);
1126 len = strlen (buff);
1127 while (*buff == ' ') {
1128 memmove (buff, buff + 1, --len);
1129 }
1130 buff[len] = 0;
1131 }
1132
1133 entry = cob_chk_call_path (buff, &dirent);
1134
1135 /* Check if system routine */
1136 for (psyst = system_tab; psyst->syst_name; ++psyst) {
1137 if (!strcmp (entry, psyst->syst_name)) {
1138 if (dirent) {
1139 cob_free (dirent);
1140 }
1141 return psyst->syst_call.funcvoid;
1142 }
1143 }
1144
1145
1146 /* Check if contained program */
1147 for (s = cs; s && s->cob_cstr_name; s++) {
1148 if (!strcmp (entry, s->cob_cstr_name)) {
1149 if (dirent) {
1150 cob_free (dirent);
1151 }
1152 return s->cob_cstr_call.funcvoid;
1153 }
1154 }
1155
1156 p = cob_resolve_internal (entry, dirent, fold_case);
1157 if (dirent) {
1158 cob_free (dirent);
1159 }
1160 if (unlikely(!p)) {
1161 if (errind) {
1162 cob_call_error ();
1163 } else {
1164 cob_set_exception (COB_EC_PROGRAM_NOT_FOUND);
1165 return NULL;
1166 }
1167 }
1168 return p;
1169 }
1170
1171 void
cob_cancel(const char * name)1172 cob_cancel (const char *name)
1173 {
1174 const char *entry;
1175 struct call_hash *p;
1176 struct call_hash **q;
1177 struct call_hash *r;
1178
1179 /* LCOV_EXCL_START */
1180 if (unlikely(!cobglobptr)) {
1181 cob_fatal_error (COB_FERROR_INITIALIZED);
1182 }
1183 if (unlikely(!name)) {
1184 cob_runtime_error (_("NULL parameter passed to '%s'"), "cob_cancel");
1185 cob_stop_run (EXIT_FAILURE);
1186 }
1187 /* LCOV_EXCL_STOP */
1188 entry = cob_chk_dirp (name);
1189
1190 #ifdef COB_ALT_HASH
1191 q = &call_table;
1192 p = *q;
1193 #else
1194 q = &call_table[hash ((const unsigned char *)entry)];
1195 p = *q;
1196 #endif
1197 r = NULL;
1198 for (; p; p = p->next) {
1199 if (strcmp (entry, p->name) == 0) {
1200 do_cancel_module (p, q, r);
1201 return;
1202 }
1203 r = p;
1204 }
1205 }
1206
1207 void
cob_cancel_field(const cob_field * f,const struct cob_call_struct * cs)1208 cob_cancel_field (const cob_field *f, const struct cob_call_struct *cs)
1209 {
1210 char *name;
1211 const char *entry;
1212 const struct cob_call_struct *s;
1213
1214 int (*cancel_func)(const int, void *, void *, void *, void *);
1215
1216 /* LCOV_EXCL_START */
1217 if (unlikely(!cobglobptr)) {
1218 cob_fatal_error (COB_FERROR_INITIALIZED);
1219 }
1220 /* LCOV_EXCL_STOP */
1221 if (!f || f->size == 0) {
1222 return;
1223 }
1224 name = cob_get_buff (f->size + 1);
1225 cob_field_to_string (f, name, f->size);
1226 entry = cob_chk_dirp (name);
1227
1228 /* Check if contained program */
1229 for (s = cs; s && s->cob_cstr_name; s++) {
1230 if (!strcmp (entry, s->cob_cstr_name)) {
1231 if (s->cob_cstr_cancel.funcvoid) {
1232 #ifdef _MSC_VER
1233 #pragma warning(suppress: 4113) /* funcint is a generic function prototype */
1234 cancel_func = s->cob_cstr_cancel.funcint;
1235 #else
1236 cancel_func = s->cob_cstr_cancel.funcint;
1237 #endif
1238 (void)cancel_func (-1, NULL, NULL, NULL,
1239 NULL);
1240 }
1241 return;
1242 }
1243 }
1244 cob_cancel (entry);
1245 }
1246
1247 int
cob_call(const char * name,const int argc,void ** argv)1248 cob_call (const char *name, const int argc, void **argv)
1249 {
1250 void **pargv;
1251 cob_call_union unifunc;
1252 int i;
1253
1254 /* LCOV_EXCL_START */
1255 if (unlikely(!cobglobptr)) {
1256 cob_fatal_error (COB_FERROR_INITIALIZED);
1257 }
1258 if (argc < 0 || argc > MAX_CALL_FIELD_PARAMS) {
1259 cob_runtime_error (_("invalid number of arguments passed to '%s'"), "cob_call");
1260 cob_stop_run (EXIT_FAILURE);
1261 }
1262 if (unlikely(!name)) {
1263 cob_runtime_error (_("NULL parameter passed to '%s'"), "cob_call");
1264 cob_stop_run (EXIT_FAILURE);
1265 }
1266 /* LCOV_EXCL_STOP */
1267 unifunc.funcvoid = cob_resolve_cobol (name, 0, 1);
1268 pargv = cob_malloc (MAX_CALL_FIELD_PARAMS * sizeof(void *));
1269 /* Set number of parameters */
1270 cobglobptr->cob_call_params = argc;
1271 for (i = 0; i < argc; ++i) {
1272 pargv[i] = argv[i];
1273 }
1274 #if MAX_CALL_FIELD_PARAMS == 16 || \
1275 MAX_CALL_FIELD_PARAMS == 36 || \
1276 MAX_CALL_FIELD_PARAMS == 56 || \
1277 MAX_CALL_FIELD_PARAMS == 76 || \
1278 MAX_CALL_FIELD_PARAMS == 96 || \
1279 MAX_CALL_FIELD_PARAMS == 192 || \
1280 MAX_CALL_FIELD_PARAMS == 252
1281 #else
1282 #error "Invalid MAX_CALL_FIELD_PARAMS value"
1283 #endif
1284 i = unifunc.funcint (pargv[0], pargv[1], pargv[2], pargv[3]
1285 ,pargv[4], pargv[5], pargv[6], pargv[7]
1286 ,pargv[8], pargv[9], pargv[10], pargv[11]
1287 ,pargv[12], pargv[13], pargv[14], pargv[15]
1288 #if MAX_CALL_FIELD_PARAMS > 16
1289 ,pargv[16], pargv[17], pargv[18], pargv[19]
1290 ,pargv[20], pargv[21], pargv[22], pargv[23]
1291 ,pargv[24], pargv[25], pargv[26], pargv[27]
1292 ,pargv[28], pargv[29], pargv[30], pargv[31]
1293 ,pargv[32], pargv[33], pargv[34], pargv[35]
1294 #if MAX_CALL_FIELD_PARAMS > 36
1295 ,pargv[36], pargv[37], pargv[38], pargv[39]
1296 ,pargv[40], pargv[41], pargv[42], pargv[43]
1297 ,pargv[44], pargv[45], pargv[46], pargv[47]
1298 ,pargv[48], pargv[49], pargv[50], pargv[51]
1299 ,pargv[52], pargv[53], pargv[54], pargv[55]
1300 #if MAX_CALL_FIELD_PARAMS > 56
1301 ,pargv[56], pargv[57], pargv[58], pargv[59]
1302 ,pargv[60], pargv[61], pargv[62], pargv[63]
1303 ,pargv[64], pargv[65], pargv[66], pargv[67]
1304 ,pargv[68], pargv[69], pargv[70], pargv[71]
1305 ,pargv[72], pargv[73], pargv[74], pargv[75]
1306 #if MAX_CALL_FIELD_PARAMS > 76
1307 ,pargv[76], pargv[77], pargv[78], pargv[79]
1308 ,pargv[80], pargv[81], pargv[82], pargv[83]
1309 ,pargv[84], pargv[85], pargv[86], pargv[87]
1310 ,pargv[88], pargv[89], pargv[90], pargv[91]
1311 ,pargv[92], pargv[93], pargv[94], pargv[95]
1312 #if MAX_CALL_FIELD_PARAMS > 96
1313 ,pargv[96], pargv[97], pargv[98], pargv[99]
1314 ,pargv[100], pargv[101], pargv[102], pargv[103]
1315 ,pargv[104], pargv[105], pargv[106], pargv[107]
1316 ,pargv[108], pargv[109], pargv[110], pargv[111]
1317 ,pargv[112], pargv[113], pargv[114], pargv[115]
1318 ,pargv[116], pargv[117], pargv[118], pargv[119]
1319 ,pargv[120], pargv[121], pargv[122], pargv[123]
1320 ,pargv[124], pargv[125], pargv[126], pargv[127]
1321 ,pargv[128], pargv[129], pargv[130], pargv[131]
1322 ,pargv[132], pargv[133], pargv[134], pargv[135]
1323 ,pargv[136], pargv[137], pargv[138], pargv[139]
1324 ,pargv[140], pargv[141], pargv[142], pargv[143]
1325 ,pargv[144], pargv[145], pargv[146], pargv[147]
1326 ,pargv[148], pargv[149], pargv[130], pargv[131]
1327 ,pargv[152], pargv[153], pargv[154], pargv[155]
1328 ,pargv[160], pargv[161], pargv[162], pargv[163]
1329 ,pargv[164], pargv[165], pargv[166], pargv[167]
1330 ,pargv[168], pargv[169], pargv[170], pargv[171]
1331 ,pargv[172], pargv[173], pargv[174], pargv[175]
1332 ,pargv[176], pargv[177], pargv[178], pargv[179]
1333 ,pargv[180], pargv[181], pargv[182], pargv[183]
1334 ,pargv[184], pargv[185], pargv[186], pargv[187]
1335 ,pargv[188], pargv[189], pargv[190], pargv[191]
1336 #if MAX_CALL_FIELD_PARAMS > 192
1337 ,pargv[192], pargv[193], pargv[194], pargv[195]
1338 ,pargv[200], pargv[201], pargv[202], pargv[203]
1339 ,pargv[204], pargv[205], pargv[206], pargv[207]
1340 ,pargv[208], pargv[209], pargv[210], pargv[211]
1341 ,pargv[212], pargv[213], pargv[214], pargv[215]
1342 ,pargv[216], pargv[217], pargv[218], pargv[219]
1343 ,pargv[220], pargv[221], pargv[222], pargv[223]
1344 ,pargv[224], pargv[225], pargv[226], pargv[227]
1345 ,pargv[228], pargv[229], pargv[230], pargv[231]
1346 ,pargv[232], pargv[233], pargv[234], pargv[235]
1347 ,pargv[240], pargv[241], pargv[242], pargv[243]
1348 ,pargv[244], pargv[245], pargv[246], pargv[247]
1349 ,pargv[248], pargv[249], pargv[250], pargv[251]
1350 #endif
1351 #endif
1352 #endif
1353 #endif
1354 #endif
1355 #endif
1356 );
1357 cob_free (pargv);
1358 return i;
1359 }
1360
1361 int
cob_func(const char * name,const int argc,void ** argv)1362 cob_func (const char *name, const int argc, void **argv)
1363 {
1364 int ret;
1365
1366 ret = cob_call (name, argc, argv);
1367 cob_cancel (name);
1368 return ret;
1369 }
1370
1371 #ifndef COB_WITHOUT_JMP
1372 void *
cob_savenv(struct cobjmp_buf * jbuf)1373 cob_savenv (struct cobjmp_buf *jbuf)
1374 {
1375 /* LCOV_EXCL_START */
1376 if (unlikely(!cobglobptr)) {
1377 cob_fatal_error (COB_FERROR_INITIALIZED);
1378 }
1379 if (unlikely(!jbuf)) {
1380 cob_runtime_error (_("NULL parameter passed to '%s'"), "cob_savenv");
1381 cob_stop_run (EXIT_FAILURE);
1382 }
1383 if (cob_jmp_primed) {
1384 cob_runtime_error (_("multiple call to 'cob_setjmp'"));
1385 cob_stop_run (EXIT_FAILURE);
1386 }
1387 /* LCOV_EXCL_STOP */
1388 cob_jmp_primed = 1;
1389 return jbuf->cbj_jmp_buf;
1390 }
1391
1392 void *
cob_savenv2(struct cobjmp_buf * jbuf,const int jsize)1393 cob_savenv2 (struct cobjmp_buf *jbuf, const int jsize)
1394 {
1395 COB_UNUSED (jsize);
1396
1397 return cob_savenv (jbuf);
1398 }
1399
1400 void
cob_longjmp(struct cobjmp_buf * jbuf)1401 cob_longjmp (struct cobjmp_buf *jbuf)
1402 {
1403 /* LCOV_EXCL_START */
1404 if (unlikely(!cobglobptr)) {
1405 cob_fatal_error (COB_FERROR_INITIALIZED);
1406 }
1407 if (unlikely(!jbuf)) {
1408 cob_runtime_error (_("NULL parameter passed to '%s'"), "cob_longjmp");
1409 cob_stop_run (EXIT_FAILURE);
1410 }
1411 if (!cob_jmp_primed) {
1412 cob_runtime_error (_("call to 'cob_longjmp' with no prior 'cob_setjmp'"));
1413 cob_stop_run (EXIT_FAILURE);
1414 }
1415 /* LCOV_EXCL_STOP */
1416 cob_jmp_primed = 0;
1417 longjmp (jbuf->cbj_jmp_buf, 1);
1418 }
1419 #endif
1420
1421 void
cob_exit_call(void)1422 cob_exit_call (void)
1423 {
1424 struct call_hash *p;
1425 struct call_hash *q;
1426 struct struct_handle *h;
1427 struct struct_handle *j;
1428
1429 #ifndef COB_ALT_HASH
1430 size_t i;
1431 #endif
1432
1433 if (call_filename_buff) {
1434 cob_free (call_filename_buff);
1435 call_filename_buff = NULL;
1436 }
1437 if (call_buffer) {
1438 cob_free (call_buffer);
1439 call_buffer = NULL;
1440 }
1441 if (resolve_error_buff) {
1442 cob_free (resolve_error_buff);
1443 resolve_error_buff = NULL;
1444 }
1445 if (resolve_alloc) {
1446 cob_free (resolve_alloc);
1447 resolve_alloc = NULL;
1448 }
1449 if (resolve_path) {
1450 cob_free (resolve_path);
1451 resolve_path = NULL;
1452 resolve_size = 0;
1453 }
1454
1455 #ifndef COB_ALT_HASH
1456 if (call_table) {
1457 for (i = 0; i < HASH_SIZE; ++i) {
1458 p = call_table[i];
1459 #else
1460 p = call_table;
1461 #endif
1462 for (; p;) {
1463 q = p;
1464 p = p->next;
1465 if (q->name) {
1466 cob_free ((void *)q->name);
1467 }
1468 if (q->path) {
1469 cob_free ((void *)q->path);
1470 }
1471 cob_free (q);
1472 }
1473 #ifndef COB_ALT_HASH
1474 }
1475 if (call_table) {
1476 cob_free (call_table);
1477 }
1478 call_table = NULL;
1479 }
1480 #endif
1481
1482 for (h = base_preload_ptr; h;) {
1483 j = h;
1484 if (h->path) {
1485 cob_free ((void *)h->path);
1486 }
1487 if (h->handle) {
1488 lt_dlclose (h->handle);
1489 }
1490 h = h->next;
1491 cob_free (j);
1492 }
1493 base_preload_ptr = NULL;
1494 for (h = base_dynload_ptr; h;) {
1495 j = h;
1496 if (h->path) {
1497 cob_free ((void *)h->path);
1498 }
1499 if (h->handle) {
1500 lt_dlclose (h->handle);
1501 }
1502 h = h->next;
1503 cob_free (j);
1504 }
1505 base_dynload_ptr = NULL;
1506
1507 #if !defined(_WIN32) && !defined(USE_LIBDL)
1508 lt_dlexit ();
1509 #if 0 /* RXWRXW - ltdl leak */
1510 #ifndef COB_BORKED_DLOPEN
1511 /* Weird - ltdl leaks mainhandle - This appears to work but .. */
1512 if (mainhandle) {
1513 cob_free (mainhandle);
1514 }
1515 #endif
1516 #endif
1517 #endif
1518
1519 }
1520
1521 void
cob_init_call(cob_global * lptr,cob_settings * sptr,const int check_mainhandle)1522 cob_init_call (cob_global *lptr, cob_settings* sptr, const int check_mainhandle)
1523 {
1524 char *s;
1525 char *p;
1526 size_t i;
1527 #ifndef HAVE_DESIGNATED_INITS
1528 const unsigned char *pv;
1529 #endif
1530 #ifdef __OS400__
1531 char *t;
1532 #endif
1533
1534 cobglobptr = lptr;
1535 cobsetptr = sptr;
1536
1537 base_preload_ptr = NULL;
1538 base_dynload_ptr = NULL;
1539 resolve_path = NULL;
1540 resolve_alloc = NULL;
1541 resolve_error = NULL;
1542 call_buffer = NULL;
1543 call_lastsize = 0;
1544 cob_jmp_primed = 0;
1545
1546 #ifndef HAVE_DESIGNATED_INITS
1547 init_valid_char = 0;
1548 memset (valid_char, 0, sizeof(valid_char));
1549 for (pv = pvalid_char; *pv; ++pv) {
1550 valid_char[*pv] = 1;
1551 }
1552 #endif
1553
1554 /* Big enough for anything from libdl/libltdl */
1555 resolve_error_buff = cob_malloc ((size_t)CALL_BUFF_SIZE);
1556
1557 #ifndef COB_ALT_HASH
1558 call_table = cob_malloc (sizeof (struct call_hash *) * HASH_SIZE);
1559 #else
1560 call_table = NULL;
1561 #endif
1562
1563 /* set static vars resolve_path (data in resolve_alloc) and resolve_size */
1564 cob_set_library_path ();
1565
1566 lt_dlinit ();
1567
1568 #ifndef COB_BORKED_DLOPEN
1569 /* only set main handle if not started by cobcrun as this
1570 saves a check for exported functions in every CALL
1571 */
1572 if (check_mainhandle) {
1573 mainhandle = lt_dlopen (NULL);
1574 } else {
1575 mainhandle = NULL;
1576 }
1577 #endif
1578
1579 call_filename_buff = cob_malloc ((size_t)COB_NORMAL_BUFF);
1580
1581 if (cobsetptr->cob_preload_str != NULL) {
1582
1583 p = cob_strdup (cobsetptr->cob_preload_str);
1584
1585 cob_free (cobsetptr->cob_preload_str);
1586 cobsetptr->cob_preload_str = NULL;
1587
1588 s = strtok (p, PATHSEP_STR);
1589 for (; s; s = strtok (NULL, PATHSEP_STR)) {
1590 char buff[COB_MEDIUM_BUFF];
1591 #ifdef __OS400__
1592 for (t = s; *t; ++t) {
1593 *t = toupper (*t);
1594 }
1595 cache_preload (t);
1596 #else
1597 for (i = 0; i < resolve_size; ++i) {
1598 snprintf (buff, (size_t)COB_MEDIUM_MAX,
1599 "%s%c%s.%s",
1600 resolve_path[i], SLASH_CHAR, s, COB_MODULE_EXT);
1601 if (cache_preload (buff)) {
1602 break;
1603 }
1604 }
1605 /* If not found, try just using the name as-is */
1606 if (i == resolve_size) {
1607 (void)cache_preload (s);
1608 }
1609 #endif
1610 }
1611 cob_free (p);
1612 }
1613 call_buffer = cob_fast_malloc ((size_t)CALL_BUFF_SIZE);
1614 call_lastsize = CALL_BUFF_SIZE;
1615 }
1616
1617 /******************************************
1618 * Routines for C interface with COBOL
1619 */
1620
1621 cob_field *
cob_get_param_field(int n,const char * caller_name)1622 cob_get_param_field (int n, const char *caller_name)
1623 {
1624 if (cobglobptr == NULL
1625 || COB_MODULE_PTR == NULL) {
1626 /* note: same message in call.c */
1627 cob_runtime_warning_external (caller_name, 1,
1628 _("cob_init() has not been called"));
1629 return NULL;
1630 }
1631 if (n < 1
1632 || n > cobglobptr->cob_call_params) {
1633 cob_runtime_warning_external (caller_name, 1,
1634 _("parameter %d is not within range of %d"),
1635 n, cobglobptr->cob_call_params);
1636 return NULL;
1637 }
1638 if (COB_MODULE_PTR->cob_procedure_params[n - 1] == NULL) {
1639 cob_runtime_warning_external (caller_name, 1,
1640 _("parameter %d is NULL"), n);
1641 return NULL;
1642 }
1643 return COB_MODULE_PTR->cob_procedure_params[n - 1];
1644 }
1645
1646 int
cob_get_num_params(void)1647 cob_get_num_params (void)
1648 {
1649 if (cobglobptr) {
1650 return cobglobptr->cob_call_params;
1651 }
1652
1653 /* note: same message in call.c */
1654 cob_runtime_warning_external ("cob_get_num_params", 1,
1655 _("cob_init() has not been called"));
1656 return -1;
1657 }
1658
1659 int
cob_get_param_type(int n)1660 cob_get_param_type (int n)
1661 {
1662 cob_field *f = cob_get_param_field (n, "cob_get_param_type");
1663 return cob_get_field_type (f);
1664 }
1665
1666 int
cob_get_param_size(int n)1667 cob_get_param_size (int n)
1668 {
1669 cob_field *f = cob_get_param_field (n, "cob_get_param_size");
1670 return cob_get_field_size (f);
1671 }
1672
1673 int
cob_get_param_sign(int n)1674 cob_get_param_sign (int n)
1675 {
1676 cob_field *f = cob_get_param_field (n, "cob_get_param_sign");
1677 return cob_get_field_sign (f);
1678 }
1679
1680 int
cob_get_param_scale(int n)1681 cob_get_param_scale (int n)
1682 {
1683 cob_field *f = cob_get_param_field (n, "cob_get_param_scale");
1684 return cob_get_field_scale (f);
1685 }
1686
1687 int
cob_get_param_digits(int n)1688 cob_get_param_digits (int n)
1689 {
1690 cob_field *f = cob_get_param_field (n, "cob_get_param_digits");
1691 return cob_get_field_digits (f);
1692 }
1693
1694 int
cob_get_param_constant(int n)1695 cob_get_param_constant (int n)
1696 {
1697 cob_field *f = cob_get_param_field (n, "cob_get_param_constant");
1698 return cob_get_field_constant (f);
1699 }
1700
1701 const char *
cob_get_param_str(int n,char * buffer,size_t size)1702 cob_get_param_str (int n, char *buffer, size_t size)
1703 {
1704 cob_field *f = cob_get_param_field (n, "cob_get_param_str");
1705 return cob_get_field_str (f, buffer, size);
1706 }
1707
1708 const char *
cob_get_param_str_buffered(int n)1709 cob_get_param_str_buffered (int n)
1710 {
1711 cob_field *f = cob_get_param_field (n, "cob_get_param_str_buffered");
1712 return cob_get_field_str_buffered (f);
1713 }
1714
1715 int
cob_put_param_str(int n,const char * str)1716 cob_put_param_str (int n, const char *str)
1717 {
1718 cob_field *f = cob_get_param_field (n, "cob_put_param_str");
1719 return cob_put_field_str (f, str);
1720 }
1721
1722 void *
cob_get_param_data(int n)1723 cob_get_param_data (int n)
1724 {
1725 cob_field *f = cob_get_param_field (n, "cob_get_param_data");
1726 if (f == NULL) {
1727 return NULL;
1728 }
1729 return (void*)f->data;
1730 }
1731
1732 double
cob_get_dbl_param(int n)1733 cob_get_dbl_param (int n)
1734 {
1735 void *cbl_data;
1736 double val;
1737 cob_field temp;
1738 cob_field_attr float_attr;
1739 cob_field *f = cob_get_param_field (n, "cob_get_dbl_param");
1740
1741 if (f == NULL) {
1742 return (double)-1;
1743 }
1744 cbl_data = f->data;
1745
1746 switch (f->attr->type) {
1747 case COB_TYPE_NUMERIC_FLOAT:
1748 return (double)cob_get_comp1 (cbl_data);
1749 case COB_TYPE_NUMERIC_DOUBLE:
1750 return (double)cob_get_comp2 (cbl_data);
1751 default:
1752 memcpy(&float_attr, &const_float_attr, sizeof(cob_field_attr));
1753 float_attr.scale = f->attr->scale;
1754 temp.size = 8;
1755 temp.data = (unsigned char *)&val;
1756 temp.attr = &float_attr;
1757 cob_move (f, &temp);
1758 return (double)val;
1759 }
1760 }
1761
1762 void
cob_put_dbl_param(int n,double val)1763 cob_put_dbl_param (int n, double val)
1764 {
1765 void *cbl_data;
1766 cob_field temp;
1767 cob_field_attr float_attr;
1768 cob_field *f = cob_get_param_field (n, "cob_get_dbl_param");
1769
1770 if (f == NULL) {
1771 return;
1772 }
1773 cbl_data = f->data;
1774
1775 switch (f->attr->type) {
1776 case COB_TYPE_NUMERIC_FLOAT:
1777 cob_put_comp1 ((float)val, cbl_data);
1778 return;
1779 case COB_TYPE_NUMERIC_DOUBLE:
1780 cob_put_comp2 (val, cbl_data);
1781 return;
1782 default:
1783 memcpy(&float_attr, &const_float_attr, sizeof(cob_field_attr));
1784 float_attr.scale = f->attr->scale;
1785 temp.size = 8;
1786 temp.data = (unsigned char *)&val;
1787 temp.attr = &float_attr;
1788 cob_move (&temp, f);
1789 return;
1790 }
1791 }
1792
1793 cob_s64_t
cob_get_s64_param(int n)1794 cob_get_s64_param (int n)
1795 {
1796 void *cbl_data;
1797 int size;
1798 cob_s64_t val;
1799 double dbl;
1800 cob_field temp;
1801 cob_field *f = cob_get_param_field (n, "cob_get_s64_param");
1802
1803 if (f == NULL) {
1804 return -1;
1805 }
1806 cbl_data = f->data;
1807 size = f->size;
1808
1809 switch (f->attr->type) {
1810 case COB_TYPE_NUMERIC_DISPLAY:
1811 return cob_get_s64_pic9 (cbl_data, size);
1812 case COB_TYPE_NUMERIC_BINARY:
1813 #ifndef WORDS_BIGENDIAN
1814 if (!COB_FIELD_BINARY_SWAP (f)) {
1815 return cob_get_s64_comp5 (cbl_data, size);
1816 }
1817 #endif
1818 return cob_get_s64_compx (cbl_data, size);
1819 case COB_TYPE_NUMERIC_PACKED:
1820 return cob_get_s64_comp3 (cbl_data, size);
1821 case COB_TYPE_NUMERIC_FLOAT:
1822 dbl = cob_get_comp1 (cbl_data);
1823 val = (cob_s64_t)dbl; /* possible data loss is explicit requested */
1824 return val;
1825 case COB_TYPE_NUMERIC_DOUBLE:
1826 dbl = cob_get_comp2 (cbl_data);
1827 val = (cob_s64_t)dbl; /* possible data loss is explicit requested */
1828 return val;
1829 case COB_TYPE_NUMERIC_EDITED:
1830 return cob_get_s64_pic9 (cbl_data, size);
1831 default:
1832 temp.size = 8;
1833 temp.data = (unsigned char *)&val;
1834 temp.attr = &const_binll_attr;
1835 const_binll_attr.scale = f->attr->scale;
1836 cob_move (f, &temp);
1837 return val;
1838 }
1839 }
1840
1841 cob_u64_t
cob_get_u64_param(int n)1842 cob_get_u64_param (int n)
1843 {
1844 void *cbl_data;
1845 int size;
1846 cob_u64_t val;
1847 double dbl;
1848 cob_field temp;
1849 cob_field *f = cob_get_param_field (n, "cob_get_u64_param");
1850
1851 if (f == NULL) {
1852 return 0;
1853 }
1854
1855 cbl_data = f->data;
1856 size = f->size;
1857 switch (COB_MODULE_PTR->cob_procedure_params[n - 1]->attr->type) {
1858 case COB_TYPE_NUMERIC_DISPLAY:
1859 return cob_get_u64_pic9 (cbl_data, size);
1860 case COB_TYPE_NUMERIC_BINARY:
1861 #ifndef WORDS_BIGENDIAN
1862 if (!COB_FIELD_BINARY_SWAP (f)) {
1863 return cob_get_u64_comp5 (cbl_data, size);
1864 }
1865 #endif
1866 return cob_get_u64_compx (cbl_data, size);
1867 case COB_TYPE_NUMERIC_PACKED:
1868 return cob_get_u64_comp3 (cbl_data, size);
1869 case COB_TYPE_NUMERIC_FLOAT:
1870 dbl = cob_get_comp1 (cbl_data);
1871 val = (cob_u64_t)dbl; /* possible data loss is explicit requested */
1872 return val;
1873 case COB_TYPE_NUMERIC_DOUBLE:
1874 dbl = cob_get_comp2 (cbl_data);
1875 val = (cob_u64_t)dbl; /* possible data loss is explicit requested */
1876 return val;
1877 case COB_TYPE_NUMERIC_EDITED:
1878 return cob_get_u64_pic9 (cbl_data, size);
1879 default:
1880 temp.size = 8;
1881 temp.data = (unsigned char *)&val;
1882 temp.attr = &const_binull_attr;
1883 const_binull_attr.scale = f->attr->scale;
1884 cob_move (f, &temp);
1885 return val;
1886 }
1887 }
1888
1889 char *
cob_get_picx_param(int n,void * char_field,size_t char_len)1890 cob_get_picx_param (int n, void *char_field, size_t char_len)
1891 {
1892 cob_field *f = cob_get_param_field (n, "cob_get_picx_param");
1893 if (f == NULL) {
1894 return NULL;
1895 }
1896 return cob_get_picx (f->data, f->size, char_field, char_len);
1897 }
1898
1899 int
cob_get_field_type(const cob_field * f)1900 cob_get_field_type (const cob_field *f)
1901 {
1902 if (f == NULL) {
1903 return -1;
1904 }
1905 if (f->attr->type == COB_TYPE_NUMERIC_BINARY) {
1906 if (COB_FIELD_REAL_BINARY (f)) {
1907 return COB_TYPE_NUMERIC_COMP5;
1908 }
1909 #ifndef WORDS_BIGENDIAN
1910 if (!COB_FIELD_BINARY_SWAP (f)) {
1911 return COB_TYPE_NUMERIC_COMP5;
1912 }
1913 #endif
1914 }
1915 return (int)f->attr->type;
1916 }
1917
1918 int
cob_get_field_size(const cob_field * f)1919 cob_get_field_size (const cob_field *f)
1920 {
1921 if (f == NULL) {
1922 return -1;
1923 }
1924 return (int)f->size;
1925 }
1926
1927 int
cob_get_field_sign(const cob_field * f)1928 cob_get_field_sign (const cob_field *f)
1929 {
1930 if (f == NULL) {
1931 return -1;
1932 }
1933 return COB_FIELD_HAVE_SIGN (f);
1934 }
1935
1936 int
cob_get_field_scale(const cob_field * f)1937 cob_get_field_scale (const cob_field *f)
1938 {
1939 if (f == NULL) {
1940 return -1;
1941 }
1942 return (int)f->attr->scale;
1943 }
1944
1945 int
cob_get_field_digits(const cob_field * f)1946 cob_get_field_digits (const cob_field *f)
1947 {
1948 if (f == NULL) {
1949 return -1;
1950 }
1951 return (int)f->attr->digits;
1952 }
1953
1954 int
cob_get_field_constant(const cob_field * f)1955 cob_get_field_constant (const cob_field *f)
1956 {
1957 if (f == NULL) {
1958 return -1;
1959 }
1960 return COB_FIELD_CONSTANT (f);
1961 }
1962
1963 const char *
cob_get_field_str(const cob_field * f,char * buffer,size_t size)1964 cob_get_field_str (const cob_field *f, char *buffer, size_t size)
1965 {
1966 if (unlikely (f == NULL)) {
1967 return _("NULL field");
1968 }
1969 /* variable field's and empty literals may be of zero size */
1970 if (unlikely (f->size == 0)) {
1971 return "";
1972 }
1973 /* check if field has data assigned (may be a BASED / LINKAGE item) */
1974 if (unlikely (f->data == NULL)) {
1975 return _("field not allocated");
1976 }
1977 if (!buffer || !size) {
1978 cob_runtime_warning_external ("cob_get_field_str", 0, "bad buffer/size");
1979 return "";
1980 }
1981 {
1982 FILE *fp;
1983 #ifdef HAVE_FMEMOPEN
1984 fp = fmemopen (buffer, size, "w");
1985 #else
1986 fp = cob_create_tmpfile ("display");
1987 #endif
1988 if (fp) {
1989 unsigned char pretty = COB_MODULE_PTR->flag_pretty_display;
1990 COB_MODULE_PTR->flag_pretty_display = 1;
1991 cob_display_common (f, fp);
1992 #ifndef HAVE_FMEMOPEN
1993 {
1994 int cur_pos = ftell (fp);
1995 if (cur_pos >= 0) {
1996 size_t pos = (size_t) cur_pos;
1997 fseek (fp, 0, SEEK_SET);
1998 fread ((void*)buffer, 1, pos, fp);
1999 if (size > pos) buffer[pos] = 0;
2000 }
2001 }
2002 #endif
2003 fclose (fp);
2004 COB_MODULE_PTR->flag_pretty_display = pretty;
2005 }
2006 }
2007 return buffer;
2008 }
2009
2010 const char *
cob_get_field_str_buffered(const cob_field * f)2011 cob_get_field_str_buffered (const cob_field *f)
2012 {
2013 char *buff = NULL;
2014 size_t size = cob_get_field_size (f) + 1;
2015
2016 if (size > 0) {
2017 if (size < 32) {
2018 size = 32;
2019 }
2020 buff = cob_get_buff (size);
2021 }
2022 return cob_get_field_str (f, buff, size);
2023 }
2024
2025 int
cob_put_field_str(const cob_field * dst,const char * str)2026 cob_put_field_str (const cob_field *dst, const char *str)
2027 {
2028 const cob_field_attr const_alpha_attr =
2029 {COB_TYPE_ALPHANUMERIC, 0, 0, 0, NULL};
2030 cob_field wrk;
2031
2032 if (!dst ||!str) return EINVAL;
2033
2034 /* come back later for DYNAMIC LENGTH fields */
2035 if (dst->size <= 0) return EINVAL;
2036
2037 if (COB_FIELD_CONSTANT (dst)) {
2038 cob_runtime_warning_external ("cob_put_field_str", 0,
2039 _ ("attempt to over-write constant field with '%s'"),
2040 str);
2041 return EINVAL;
2042 }
2043
2044
2045 wrk.attr = &const_alpha_attr;
2046 wrk.size = strlen (str);
2047 wrk.data = (unsigned char *)str;
2048
2049 if (COB_FIELD_IS_NUMERIC (dst)) {
2050 if (COB_FIELD_TYPE (dst) & COB_TYPE_NUMERIC_FLOAT
2051 || COB_FIELD_TYPE (dst) & COB_TYPE_NUMERIC_DOUBLE) {
2052 if (cob_check_numval_f (&wrk)) return 1;
2053 wrk = *cob_intr_numval_f (&wrk);
2054 } else {
2055 if (cob_check_numval (&wrk, NULL, 0, 1)) return 1;
2056 wrk = *cob_intr_numval (&wrk);
2057 }
2058 }
2059 cob_move (&wrk, (cob_field *)dst);
2060 return 0;
2061 }
2062
2063 void
cob_put_s64_param(int n,cob_s64_t val)2064 cob_put_s64_param (int n, cob_s64_t val)
2065 {
2066 void *cbl_data;
2067 int size;
2068 float flt;
2069 double dbl;
2070 cob_field temp;
2071 cob_field *f = cob_get_param_field (n, "cob_put_s64_param");
2072
2073 if (f == NULL) {
2074 return;
2075 }
2076
2077 if (COB_FIELD_CONSTANT (f)) {
2078 cob_runtime_warning_external ("cob_put_s64_param", 1,
2079 _("attempt to over-write constant parameter %d with " CB_FMT_LLD),
2080 n, val);
2081 return;
2082 }
2083 cbl_data = f->data;
2084 size = f->size;
2085 switch (f->attr->type) {
2086 case COB_TYPE_NUMERIC_DISPLAY:
2087 cob_put_s64_pic9 (val, cbl_data, size);
2088 return;
2089 case COB_TYPE_NUMERIC_BINARY:
2090 #ifndef WORDS_BIGENDIAN
2091 if (!COB_FIELD_BINARY_SWAP (f)) {
2092 cob_put_s64_comp5 (val, cbl_data, size);
2093 return;
2094 }
2095 #endif
2096 cob_put_s64_compx (val, cbl_data, size);
2097 return;
2098 case COB_TYPE_NUMERIC_PACKED:
2099 cob_put_s64_comp3 (val, cbl_data, size);
2100 return;
2101 case COB_TYPE_NUMERIC_FLOAT:
2102 flt = (float)val; /* possible data loss is explicit requested */
2103 cob_put_comp1 (flt, cbl_data);
2104 return;
2105 case COB_TYPE_NUMERIC_DOUBLE:
2106 dbl = (double)val; /* possible data loss is explicit requested */
2107 cob_put_comp2 (dbl, cbl_data);
2108 return;
2109 default: /* COB_TYPE_NUMERIC_EDITED, ... */
2110 temp.size = 8;
2111 temp.data = (unsigned char *)&val;
2112 temp.attr = &const_binll_attr;
2113 const_binll_attr.scale = f->attr->scale;
2114 cob_move (&temp, f);
2115 return;
2116 }
2117 }
2118
2119 void
cob_put_u64_param(int n,cob_u64_t val)2120 cob_put_u64_param (int n, cob_u64_t val)
2121 {
2122 void *cbl_data;
2123 int size;
2124 float flt;
2125 double dbl;
2126 cob_field temp;
2127 cob_field *f = cob_get_param_field (n, "cob_put_u64_param");
2128
2129 if (f == NULL) {
2130 return;
2131 }
2132
2133 if (COB_FIELD_CONSTANT (f)) {
2134 cob_runtime_warning_external ("cob_put_u64_param", 1,
2135 _("attempt to over-write constant parameter %d with " CB_FMT_LLD),
2136 n, val);
2137 return;
2138 }
2139 cbl_data = f->data;
2140 size = f->size;
2141 switch (f->attr->type) {
2142 case COB_TYPE_NUMERIC_DISPLAY:
2143 cob_put_u64_pic9 (val, cbl_data, size);
2144 return;
2145 case COB_TYPE_NUMERIC_BINARY:
2146 #ifndef WORDS_BIGENDIAN
2147 if (!COB_FIELD_BINARY_SWAP (f)) {
2148 cob_put_u64_comp5 (val, cbl_data, size);
2149 return;
2150 }
2151 #endif
2152 cob_put_u64_compx (val, cbl_data, size);
2153 return;
2154 case COB_TYPE_NUMERIC_PACKED:
2155 cob_put_u64_comp3 (val, cbl_data, size);
2156 return;
2157 case COB_TYPE_NUMERIC_FLOAT:
2158 flt = (float)val; /* possible data loss is explicit requested */
2159 cob_put_comp1 (flt, cbl_data);
2160 return;
2161 case COB_TYPE_NUMERIC_DOUBLE:
2162 dbl = (double)val; /* possible data loss is explicit requested */
2163 cob_put_comp2 (dbl, cbl_data);
2164 return;
2165 default: /* COB_TYPE_NUMERIC_EDITED, ... */
2166 temp.size = 8;
2167 temp.data = (unsigned char *)&val;
2168 temp.attr = &const_binll_attr;
2169 const_binll_attr.scale = f->attr->scale;
2170 cob_move (&temp, f);
2171 return;
2172 }
2173 }
2174
2175 void
cob_put_picx_param(int n,void * char_field)2176 cob_put_picx_param (int n, void *char_field)
2177 {
2178 cob_field *f = cob_get_param_field (n, "cob_put_picx_param");
2179
2180 if (f == NULL || char_field == NULL) {
2181 return;
2182 }
2183
2184 if (COB_FIELD_CONSTANT (f)) {
2185 cob_runtime_warning_external ("cob_put_picx_param", 1,
2186 _("attempt to over-write constant parameter %d with '%s'"),
2187 n, (char*)char_field);
2188 return;
2189 }
2190
2191 cob_put_picx (f->data, f->size, char_field);
2192 }
2193
2194 void *
cob_get_grp_param(int n,void * char_field,size_t len)2195 cob_get_grp_param (int n, void *char_field, size_t len)
2196 {
2197 cob_field *f = cob_get_param_field (n, "cob_get_grp_param");
2198
2199 if (f == NULL) {
2200 return NULL;
2201 }
2202 if (len == 0) {
2203 len = f->size;
2204 }
2205
2206 if (char_field == NULL) {
2207 if (len < f->size) {
2208 len = f->size;
2209 }
2210 char_field = cob_malloc (len);
2211 }
2212 memcpy (char_field, f->data, f->size);
2213 return char_field;
2214 }
2215
2216 void
cob_put_grp_param(int n,void * char_field,size_t len)2217 cob_put_grp_param (int n, void *char_field, size_t len)
2218 {
2219 cob_field *f = cob_get_param_field (n, "cob_put_grp_param");
2220
2221 if (f == NULL || char_field == NULL) {
2222 return;
2223 }
2224
2225 if (COB_FIELD_CONSTANT (f)) {
2226 cob_runtime_warning_external ("cob_put_grp_param", 1,
2227 "attempt to over-write constant parameter %d", n);
2228 return;
2229 }
2230
2231 if (len == 0 || len > f->size) {
2232 len = f->size;
2233 }
2234 memcpy (f->data, char_field, len);
2235 }
2236
2237 /* Create copy of field and mark as a CONSTANT */
2238 void
cob_field_constant(cob_field * f,cob_field * t,cob_field_attr * a,void * d)2239 cob_field_constant (cob_field *f, cob_field *t, cob_field_attr *a, void *d)
2240 {
2241 memcpy((void*)t, (void*)f, sizeof(cob_field));
2242 memcpy((void*)a, (void*)f->attr, sizeof(cob_field_attr));
2243 t->data = d;
2244 t->attr = a;
2245 a->flags |= COB_FLAG_CONSTANT;
2246 memcpy((void*)t->data, (void*)f->data, f->size);
2247 }
2248