nilopaim
/
tinycobol
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
tinycobol/lib/dyncall.c

707 lines
18 KiB
C
Raw Permalink Blame History

//
// Copyright (C) 2001, 2000, 1999, Rildo Pragana, Jim Noeth,
// Andrew Cameron, David Essex.
// Copyright (C) 1993, 1991 Rildo Pragana.
//
// This library is free software; you can redistribute it and/or
// modify it under the terms of the GNU Lesser General Public License
// as published by the Free Software Foundation; either version 2.1,
// or (at your option) any later version.
//
// This library is distributed in the hope that it will be useful,
// but WITHOUT ANY WARRANTY; without even the implied warranty of
// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
// GNU Lesser General Public License for more details.
//
// You should have received a copy of the GNU Lesser General Public
// License along with this library; see the file COPYING.LIB. If
// not, write to the Free Software Foundation, Inc., 59 Temple Place,
// Suite 330, Boston, MA 02111-1307 USA
//
// TinyCOBOL Run Time Library
// Dynamic CALL statement functions
//
#include "htcoblib.h"
#include "rterrors.h"
#ifndef PATH_MAX
#define PATH_MAX 1024
#endif
#define SUBR_HASHLEN 128
#define HTCOB_PATH_PWD_STR "."
/* max of 64 chars sub-routine names */
#define HTCOB_DYNLIBS_MAX_NAME 65
#ifdef __MINGW32__
#include "dlfcnwin32.h"
#else
#include <dlfcn.h>
#include <glob.h>
#endif // MINGW32
#ifdef __WINDOWS__
#define HTCOB_DYNLIBS_PATTERN "*.dll"
#define HTCOB_DYNLIBS_SUFIX ".dll"
#define HTCOB_PATH_SEP_CHAR ';'
#define HTCOB_PATH_DELIM_STR "\\"
#else
#define HTCOB_DYNLIBS_PATTERN "*.so"
#define HTCOB_DYNLIBS_SUFIX ".so"
#define HTCOB_PATH_SEP_CHAR ':'
#define HTCOB_PATH_DELIM_STR "/"
#endif
extern struct runelement_info *running_element; // walter 12-12-05 /* the current run element */
extern struct element_order *elementorder; // walter 12-12-05
/* store sub-routine names */
static char subrname[PATH_MAX];
static char subr_libname[PATH_MAX];
static struct resolve_handle
{
void *handle;
struct resolve_handle *next;
} *resolve_handles = NULL;
/*
this mini-symtable will register previously called subroutines
to speed up resolving their names to pointers
*/
static struct subr_desc
{
char name[255];
void *(*subr)();
struct subr_desc *next;
} subrtab[SUBR_HASHLEN];
#ifndef __MINGW32__
static char libs_pattern[] = HTCOB_DYNLIBS_PATTERN;
#endif
/*------------------------------------------------------------------------*\
| |
| subr_hash |
| |
\*------------------------------------------------------------------------*/
static int
subr_hash(char *s)
{
int val = 0, i;
for (i = 0; s[i] != '\0'; i++)
val += s[i];
return (val % SUBR_HASHLEN);
}
/*------------------------------------------------------------------------*\
| |
| savename |
| |
\*------------------------------------------------------------------------*/
static char *
savename(char *s)
{
char *ap;
if ((ap = (char *) tcob_malloc(strlen(s) + 1)) != NULL)
strcpy(ap, s);
return (ap);
}
/*------------------------------------------------------------------------*\
| |
| subr_lookup |
| |
\*------------------------------------------------------------------------*/
static int initialized = 0;
static struct subr_desc *
subr_lookup(char *s)
{
struct subr_desc *sd;
if (!initialized)
{
memset(&subrtab[0], 0x00, sizeof (subrtab));
initialized = 1;
return NULL;
}
for (sd = &subrtab[subr_hash(s)]; sd != NULL; sd = sd->next)
if (strcmp(s, sd->name) == 0)
return sd;
return NULL;
}
/*------------------------------------------------------------------------*\
| |
| subr_install |
| |
\*------------------------------------------------------------------------*/
static struct subr_desc *
subr_install(char *name, void *(*subr)())
{
int val;
struct subr_desc *sd = subr_lookup(name);
struct element_order *eo = NULL;
struct element_order *eop = NULL;
if (sd == NULL)
{
sd = tcob_malloc(sizeof (struct subr_desc));
if (sd == NULL)
return NULL;
strcpy(sd->name, name);
val = subr_hash(sd->name);
sd->next = &subrtab[val];
sd->subr = subr;
memcpy(&subrtab[val], sd, sizeof (struct subr_desc));
free(sd);
}
eo = elementorder;
eop = eo;
while (eo)
{ // find module name
if (!strcmp(name, eo->module_name))
break;
eop = eo;
eo = eo->next;
}
if (!eo)
{
eo = calloc(1, sizeof (struct element_order));
if (!elementorder) // first try
elementorder = eo;
else
eop->next = eo;
eo->module_name = savename(name);
eo->who_call = savename(running_element->name); //calloc(1, strlen(running_element->name)+1);
eo->next = NULL;
}
return sd;
}
/*------------------------------------------------------------------------*\
| |
| subr_uninstall |
| |
\*------------------------------------------------------------------------*/
static void
subr_uninstall(char *name)
{
struct subr_desc *sd = NULL;
struct subr_desc *ant = NULL;
int hash;
hash = subr_hash(name);
for (sd = &subrtab[hash]; sd; sd = sd->next)
{
if (strcmp(name, sd->name) == 0)
{
if (!ant)
memcpy(&subrtab[hash], sd->next, sizeof (struct subr_desc));
else
ant->next = sd->next;
memset(sd,0x00, sizeof (struct subr_desc));
return;
}
ant = sd;
}
}
/*------------------------------------------------------------------------*\
| |
| module_install |
| |
\*------------------------------------------------------------------------*/
static void
module_install(void *module)
{
struct resolve_handle *rh;
rh = tcob_malloc(sizeof (struct resolve_handle));
rh->handle = module;
rh->next = resolve_handles;
resolve_handles = rh;
}
/*------------------------------------------------------------------------*\
| |
| tcob_resolve_subr_error |
| |
\*------------------------------------------------------------------------*/
void
tcob_resolve_subr_error(void)
{
fprintf(stderr, "*** RT Error: dynamic library call \"%s\" not found!\n",subrname);
}
/*
*
* tcob_resolve_in_previous_libs
*
* Try to resolve a routine handler on previous opened libs
*
*
*/
static void *
tcob_resolve_in_previous_libs(char *subrname)
{
struct resolve_handle *rh;
void *(* _dynsubr)() = NULL;
for (rh = resolve_handles; rh != NULL; rh = rh->next)
{
_dynsubr = dlsym(rh->handle, subrname);
if (_dynsubr != NULL)
{
subr_install(subrname, _dynsubr);
return _dynsubr;
}
}
return NULL;
}
/*
*
* tcob_cancel_subr
*
* Cancel a dynamically loaded module and uninstall it.
*
*/
void
tcob_cancel_subr(char *name, char *running)
{
struct element_order *eo;
struct element_order *eop;
eo = elementorder;
eop = eo;
while (eo)
{
if (strcmp(name, eo->module_name) != 0)
break;
eop = eo;
eo = eo->next;
}
if (!eo)
return;
if (strcmp(running, eo->who_call) != 0) // you can't remove module that you did't call
return;
eop->next = NULL;
if (eo->next)
eop->next = eo->next;
if (eo == elementorder)
{
free(elementorder);
elementorder = eop->next;
}
else
free(eo);
subr_uninstall(name);
}
/*
* tcob_find_in_lib
*
* Try to find a library handler on a library name
*
*/
static void *
tcob_find_in_lib(char *rutname, char *libname)
{
void *(* _dynsubr)() = NULL;
void *module;
module = dlopen(libname, RTLD_LAZY);
if (module != NULL)
{
_dynsubr = dlsym(module, subrname);
if (_dynsubr != NULL)
{
subr_install(rutname, _dynsubr);
// save for speeding up next search
module_install(module);
// return the resolved handler
return _dynsubr;
}
dlclose(module);
}
return NULL;
}
/*
* tcob_resolve
*
* Try to resolve the routine name
* The paths specified by LD_LIBRARY_PATH and TCOB_LD_LIBRARY_PATH
*
*/
void *
tcob_resolve(char *subrname)
{
void *(* _dynsubr)() = NULL;
#ifndef __MINGW32__
glob_t g;
char **libname;
char *ldlib = NULL, *libs1 = NULL, *libstmp = NULL;
#else
char *libs1 = NULL, *libstmp = NULL;
#endif
char *libs = NULL;
struct subr_desc *sd; // walter 25-10-05
//char *libs1 = NULL, *libstmp=NULL;
// search in previously opened library handles
// check if we've not seen this before
if ((sd = subr_lookup(subrname)) != NULL)
{ // walter 25-10-05
return (sd->subr);
}
// search our currently linked libraries
// and the calling program
#ifndef __MINGW32__
_dynsubr = tcob_find_in_lib(subrname, NULL);
if (_dynsubr)
{
return _dynsubr;
}
// This may be equivalent but does not seam to work on Win32
// #else
// GetModuleFileName (NULL, subr_libname, sizeof (subr_libname));
// _dynsubr = tcob_find_in_lib(subrname, subr_libname);
// if (_dynsubr) {
// return _dynsubr;
// }
#endif
// search in previously opened library handles
_dynsubr = tcob_resolve_in_previous_libs(subrname);
if (_dynsubr)
{
return _dynsubr;
}
// First find a library named as the routine on all the library path
_dynsubr = tcob_find_in_lib(subrname, subrname);
if (_dynsubr)
{
return _dynsubr;
}
// The following search sequence is not really required on MinGW (Win32)
#ifndef __MINGW32__
// find rutname.so
strcpy(subr_libname, subrname);
strcat(subr_libname, HTCOB_DYNLIBS_SUFIX);
_dynsubr = tcob_find_in_lib(subrname, subr_libname);
if (_dynsubr)
{
return _dynsubr;
}
// find ./rutname.so
strcpy(subr_libname, ".");
strcat(subr_libname, HTCOB_PATH_DELIM_STR);
strcat(subr_libname, subrname);
strcat(subr_libname, HTCOB_DYNLIBS_SUFIX);
_dynsubr = tcob_find_in_lib(subrname, subr_libname);
if (_dynsubr)
{
return _dynsubr;
}
// find ./librutname.so
strcpy(subr_libname, ".");
strcat(subr_libname, HTCOB_PATH_DELIM_STR);
strcat(subr_libname, "lib");
strcat(subr_libname, subrname);
strcat(subr_libname, HTCOB_DYNLIBS_SUFIX);
_dynsubr = tcob_find_in_lib(subrname, subr_libname);
if (_dynsubr)
{
return _dynsubr;
}
#endif
// The following functionality is not implimented on MinGW (Win32)
#ifndef __MINGW32__
// Now find the modules on the current dir and on the TC library PATH
// setup our libraries names to search (in current directory)
g.gl_offs = 0;
glob(libs_pattern, 0, NULL, &g);
// add libraries found in HTCOB_LD_PATH
libs1 = getenv(HTCOB_LD_PATH);
if (libs1 != NULL)
{
libstmp = tcob_malloc(strlen(libs1) + 1);
strcpy(libstmp, libs1);
libs1 = libstmp;
}
// find all the libraryes on the HTCOB_LD_PATH
while ((libs = libs1) != NULL)
{
if ((libs1 = strchr(libs, HTCOB_PATH_SEP_CHAR)) != NULL)
{
*libs1++ = 0;
}
ldlib = tcob_malloc(strlen(libs) + strlen(libs_pattern) + 2);
strcpy(ldlib, libs);
strcat(ldlib, HTCOB_PATH_DELIM_STR);
strcat(ldlib, libs_pattern);
glob(ldlib, GLOB_APPEND, NULL, &g);
free(ldlib);
}
if (libstmp != NULL)
free(libstmp);
// loop until we find a function with the name given
libname = g.gl_pathv;
if (libname != NULL)
{
for (; *libname != NULL; libname++)
{
_dynsubr = tcob_find_in_lib(subrname, *libname);
if (_dynsubr != NULL)
{
return _dynsubr;
}
}
}
globfree(&g);
#else
HANDLE findFileHandle = NULL;
WIN32_FIND_DATA uFindFileData, *lpFindFileData;
lpFindFileData = &uFindFileData;
// Since the calling program is not a DLL
// This does not work on Win32
/*
//
// Search the calling program
//
fprintf(stderr, "dyncall debug 101 : subrname=%s, subr_libname=%s;\n", subrname, subr_libname);
mNameLen = GetModuleFileName (NULL, subr_libname, sizeof (subr_libname));
if (mNameLen != 0) {
fprintf(stderr, "dyncall debug 103 : subrname=%s, subr_libname=%s;\n", subrname, subr_libname);
mHandle = GetModuleHandle(subr_libname);
if (mHandle != NULL) {
fprintf(stderr, "dyncall debug 105 : subrname=%s, subr_libname=%s;\n", subrname, subr_libname);
_dynsubr = dlsym(mHandle, subrname);
if (_dynsubr != NULL) {
fprintf(stderr, "dyncall debug 107 : subrname=%s, subr_libname=%s;\n", subrname, subr_libname);
return _dynsubr;
}
}
}
*/
//
// Search loaded DLL's
//
// fprintf(stderr, "dyncall debug 111 : subrname=%s, subr_libname=%s;\n", subrname, subr_libname);
_dynsubr = tcob_resolve_in_previous_libs(subrname);
if (_dynsubr)
{
// fprintf(stderr, "Already loaded : subrname=%s, subr_libname=%s;\n", subrname, subr_libname);
return _dynsubr;
}
//
// Locate and search DLL's in the TCOB_LD_LIBRARY_PATH paths
//
libs1 = getenv(HTCOB_LD_PATH);
if (libs1 != NULL)
{
libstmp = tcob_malloc(strlen(libs1) + 1);
strcpy(libstmp, libs1);
libs = libstmp;
//
// Find all DLL's in the TCOB_LD_LIBRARY_PATH paths
//
// libs contains the search path
// libs1 will point to each directory to search
char * psc = tcob_malloc(2);
sprintf(psc, "%c", HTCOB_PATH_SEP_CHAR);
libs1 = strtok(libs, psc);
while (libs1 != NULL)
{
strcpy(subr_libname, libs1);
strcat(subr_libname, HTCOB_PATH_DELIM_STR);
strcat(subr_libname, HTCOB_DYNLIBS_PATTERN);
// printf("Searching on [%s]\n",subr_libname);
// get first dll from the current searched directory
findFileHandle = FindFirstFile(subr_libname, lpFindFileData);
if (findFileHandle != INVALID_HANDLE_VALUE)
{
strcpy(subr_libname, lpFindFileData->cFileName);
_dynsubr = tcob_find_in_lib(subrname, subr_libname);
if (_dynsubr)
{
return _dynsubr;
}
// get second to last dll from the current searched directory
while (FindNextFile(findFileHandle, lpFindFileData) == TRUE)
{
strcpy(subr_libname, lpFindFileData->cFileName);
_dynsubr = tcob_find_in_lib(subrname, subr_libname);
if (_dynsubr)
{
return _dynsubr;
}
}
}
// did not found yet... will search next directory on the search path
libs1 = strtok(NULL, psc);
}
free(libstmp);
}
#endif
return NULL;
}
/*------------------------------------------------------------------------*\
| |
| tcob_resolve_subr |
| |
\*------------------------------------------------------------------------*/
void *
tcob_resolve_subr(struct fld_desc *f, char *s, int stacklen)
{
char *p;
// get our subroutine name to call
strncpy(subrname, s, f->len);
subrname[f->len] = 0;
// remove trailing spaces
p = subrname;
while (*p)
{
if (*p == ' ')
*p = '\0';
if (*p == '-')
*p = '_';
p++;
}
// An non-zero stack length implies an WINAPI call convention
if (stacklen != 0)
{
sprintf(subr_libname, "%s@%d", subrname, stacklen - 1);
strcpy(subrname, subr_libname);
}
#ifndef __MINGW32__
if (strlen(subrname) > HTCOB_DYNLIBS_MAX_NAME)
{
fprintf(
stderr,
"*** RT Error: Maximun of length of %d characters in sub-routine name ('%s') execced.\n",
HTCOB_DYNLIBS_MAX_NAME, subrname);
return NULL;
}
#endif
// FIXME: check for invalid characters
// change - by _ on sub name
// p=subrname;
// while(*p){
// if (*p=='-') *p='_';
// p++;
// }
return tcob_resolve(subrname);
}
int
tcob_call_loadlib(struct fld_desc *f, char *s)
{
int r = 0;
char *p;
void *module;
strncpy(subrname, s, f->len);
subrname[f->len] = '\0';
// remove traling spaces and add NULL delimiter
p = subrname; // walter
while (*p)
{
if (*p == ' ')
*p = '\0';
p++;
}
// open the library
module = dlopen(subr_libname, RTLD_LAZY);
if (module != NULL)
{
// save handle to improve search sequence for next search
module_install(module);
r = 1;
}
return r;
}
/* end of dyncall.c */
Reference in New Issue View Git Blame Copy Permalink