/* Copyright 1989-93 GROUPE BULL -- See license conditions in file COPYRIGHT */
/*****************************************************************************\
*                                                                             *
* 				     KLDLOAD                                  *
* 			   Dynamic Load Functions                             *
*                                                                             *
\*****************************************************************************/
/* low-level interface. high-level, autoloadable layer must be written upon it
 * dynamic loading is implemented on top of the dlopen, dlsym, dlclose, dlerror
 * set of functions (SUN, SGI)
 * may be implemented on top of load, unload, loadbind, loadquery on AIX
 * the module name is the C-legal identifier prefix of the file name (cutting 
 * after first dot or minus for instance
 * and KlDLOpen calls at load time the <modulename>Init() C func.
 */

#ifdef KLDLOAD

/* To create a loadable module foo.so from foo.c:
 * cc -pic -c foo.c
 * ld -o foo.so foo.o <add-needed-libraries-here>
 */

/*****************************************************************************\
* 				 declarations                                 *
\*****************************************************************************/
#include <dlfcn.h>
#include <ctype.h>

#include "EXTERN.h"
#include "klone.h"
#include "kl_number.h"
#include "kl_string.h"
#include "kl_atom.h"
#include "kl_func.h"
#include "klgeneric.h"

DECLARE_strrchr;

typedef struct _KlDlHandle {
    KlKLONE_HEADER;
    void *handle;			/* opaque type, loaded object */
    char *name;
}        *KlDlHandle;

#define KlIsADlHandle(obj)  ((obj)->type == KlDlHandleType)
#define KlMustBeDlHandle(obj, n)  \
    if (obj->type != KlDlHandleType || !(((KlDlHandle) obj)->handle)) \
        KlBadArgument(obj, n, "open DlHandle")

KlType KlDlHandleType;
KlAtom KlDlErrorTag;

typedef void (*func_returning_void_ptr)(); 

/*****************************************************************************\
* 				  functions                                   *
\*****************************************************************************/

KlDlHandle
KlDlmake(handle, name)
    void *handle;
    char *name;
{
    KlDlHandle obj = (KlDlHandle) KlOMake(KlDlHandleType);
    obj->handle = handle;
    obj->name = KlStrdup(name);
    return obj;
} 

KlO
KlDlfree(obj)
    KlDlHandle obj;
{
    if (obj->handle)
	dlclose(obj->handle);
    Free(obj->name);
    Free(obj);
    return (KlO) obj;
} 

KlO
KlDlError(where, what)
    char *where;
    KlO what;
{
    const char *err = dlerror();
    return KlError3(KlDlErrorTag, KlStringMake(where),
		    KlStringMake(err ? err : "unknown"), what);
}

/* dlopen loads the module, and calls its function KloneModuleInit() if exists 
 * returns a DlHandle that MUST be stored, as the module is freed as soon as
 * the Klone handle is garbaged!
 * init function is name of file (first part, truncated at first 
 * non-alphanumeric or underscore char) with Init postpended:
 * filename = Tk_fileselect-1.0  ==> function is Tk_fileselectInit();
 */

KlO
KlDlopen(filename)
    KlString filename;
{
    void *handle;

    KlMustBeString(filename, 0);
    if (handle = dlopen(KlExpandTildeForFilesC(filename->string), 1)) {
	func_returning_void_ptr init_func;
	char modulename[256], *p, *q;
	if (p = strrchr(filename->string, '/')) {
	    p++;
	} else {
	    p = filename->string;
	}
	for (q = p; isalnum(*q) || (*q == '_'); q++) /* upto non-alphanum or _ */
	    ;
	bcopy(p, modulename, q - p);
	strcpy(modulename + (q - p), "Init");
	if (init_func = (func_returning_void_ptr)
	    dlsym(handle, modulename)) {
	    (*init_func)();
	}
	return (KlO) KlDlmake(handle, modulename);
    } else {				/* error */
	return KlDlError("dlopen", filename);
    }
}

/* dlclose unloads the module, and calls its C function KloneModuleFini() 
 * if it exists 
 */
KlO
KlDlclose(kldlhandle)
    KlDlHandle kldlhandle;
{
    func_returning_void_ptr fini_func;
    char modulename[256];
    KlMustBeDlHandle(kldlhandle, 0);

    strcpy(stpcpy(modulename, kldlhandle->name), "Fini");
    if (fini_func = (func_returning_void_ptr)
	dlsym(kldlhandle->handle, modulename)) {
	(*fini_func)();
    }

    if (dlclose(kldlhandle->handle)) {	/* error */
	return KlDlError("dlclose", kldlhandle);
    } else {
	kldlhandle->handle = 0;
	return NIL;
    }
}

/* dlsym declares (binds) a C symbol 
 */
KlO
KlDlsym(kldlhandle, name, type, arity)
    KlDlHandle kldlhandle;
    KlString name;
    KlType type;			/* type of symbol: Subr, FSubr */
    KlNumber arity;			/* arity of Subrs */
{
    void *Cobj;
    KlMustBeDlHandle(kldlhandle, 0);
    KlMustBeString(name, 1);
    KlMustBeType(type, 2);
    KlMustBeNumber(arity, 3);

    if (Cobj = dlsym(kldlhandle->handle, name->string)) {
	if (type != KlFSubrType && type != KlSubrType) {
	    KlBadArgument(type, 2, KlTypeErr_SubrOrFSubr);
	}
	if (arity->number < NARY || arity->number >= KlSelectorsPropsSize) {
	    char tmp[60];
	    sprintf(tmp, "integer between 0 and %d", KlSelectorsPropsSize - 1);
	    KlBadArgument(arity, 3, tmp);
	}
	return (KlO) KlSubrMake(type, Cobj, arity->number);
    } else {
	return KlDlError("dlsym", name);
    }
}

/*****************************************************************************\
* 				     Init                                     *
\*****************************************************************************/

KlDlInit()
{
    KlDeclareType(&KlDlHandleType, "DlHandle", sizeof(struct _KlDlHandle));
    KlDeclareMethod1(KlDlHandleType, KlSelFree, KlDlfree);

    KlDeclareSubr(KlDlopen, "Dl:open", 1);
    KlDeclareSubr(KlDlclose, "Dl:close", 1);
    KlDeclareSubr(KlDlsym, "Dl:symbol", 4);

					/* error */
    KlDlErrorTag = KlErrorCodeMakeS("Errors:Dl", 
				    "Dynamic loader error: %0: %2: %1");

}

#endif /* KLDLOAD */