#include <somcls.h>
#include <somobj.h>
/* In SOM 'any' is struct */
#define any Perlish_any
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
#undef any
#define tk_shift_ (' ' + 1)
#ifndef SOM_VA_INIBUFSIZE
# define SOM_VA_INIBUFSIZE (sizeof(void*) * 20)
#endif
typedef struct mysomVa {
char *start;
va_list current;
char *last;
// char buf[SOM_VA_BUFSIZE];
} *MYsomVaBuf;
MYsomVaBuf
MYsomVaBuf_create(void *ign1 , int ign2)
{
MYsomVaBuf vb;
New(1313, vb, 1, struct mysomVa);
New(1314, vb->start, SOM_VA_INIBUFSIZE, char);
vb->current = (va_list)vb->start;
vb->last = vb->start + SOM_VA_INIBUFSIZE;
return vb;
}
int
MYsomVaBuf_add(MYsomVaBuf vb, char *arg, int type)
{
/* Max size is double... */
if ((char *)vb->current + sizeof(double) > vb->last) {
STRLEN l = (char *)vb->current - vb->start;
STRLEN size = vb->last - vb->start;
size *= 2;
Renew(vb->start, size, char);
vb->current = (va_list)(vb->start + l);
vb->last = vb->start + size;
}
switch (type) {
case tk_TypeCode:
default:
croak("Do not know how to treat specifier %d for varargs",
type);
case tk_short:
va_arg(vb->current, short) = *(short*)arg;
break;
case tk_ushort:
va_arg(vb->current,unsigned short) = *(unsigned short*)arg;
break;
case tk_long:
va_arg(vb->current, long) = *(long*)arg;
break;
case tk_ulong:
va_arg(vb->current, unsigned long) = *(unsigned long*)arg;
break;
case tk_float:
va_arg(vb->current, float) = *(float*)arg;
break;
case tk_double:
va_arg(vb->current, double) = *(double*)arg;
break;
case tk_char:
va_arg(vb->current, char) = *(char*)arg;
break;
case tk_boolean:
va_arg(vb->current, int) = *(int*)arg;
break;
case tk_octet:
va_arg(vb->current, unsigned char) = *(unsigned char*)arg;
break;
case tk_enum:
va_arg(vb->current, unsigned long) = *(unsigned long*)arg;
break;
case tk_string:
va_arg(vb->current, char*) = *(char**)arg;
break;
case tk_pointer:
va_arg(vb->current, void*) = *(void**)arg;
break;
}
return 1;
}
void
MYsomVaBuf_get_valist(MYsomVaBuf vb, va_list *vap)
{
*vap = (va_list)vb->start;
}
void
MYsomVaBuf_destroy(MYsomVaBuf vb)
{
Safefree(vb->start);
Safefree(vb);
}
Environment *main_ev;
SOMClass *
PSOM_Find_Class(char *name, int major, int minor, char *dll)
{
somId nameId = SOM_IdFromString(name);
SOMClass *classobj;
if (dll)
classobj = _somFindClsInFile(SOMClassMgrObject, nameId, major, minor, dll);
else
classobj = _somFindClass(SOMClassMgrObject, nameId, major, minor);
SOMFree(nameId);
return classobj;
}
int
PSOM_Dispatch0(SOMObject *obj, char *name)
{
somId methId = SOM_IdFromString(name);
SOMClass *classobj;
int rc;
rc = _somDispatch(obj, /*retval*/ (somToken *) 0, methId, obj, main_ev);
SOMFree(methId);
return rc;
}
/* SOMObject_somDispatch() exits the process if method cannot be resolved */
static int
MYsomDispatch( SOMObject *obj, /* target for somDispatch */
somToken *ret, /* dispatched method result */
somId methId, /* the somId for meth */
va_list start_val)
{
SOMClass *class = _somGetClass(obj);
somMethodData md;
int rc = _somGetMethodData(class, methId, &md);
if (!rc)
croak("Can't resolve a SOM method");
return somApply(obj, ret, &md, start_val);
}
#define PSOM_NewObject(classobj) ((SOMObject *) _somNew(classobj))
#define ttk_void() tk_void
#define ttk_short() tk_short
#define ttk_ushort() tk_ushort
#define ttk_long() tk_long
#define ttk_ulong() tk_ulong
#define ttk_float() tk_float
#define ttk_double() tk_double
#define ttk_char() tk_char
#define ttk_boolean() tk_boolean
#define ttk_octet() tk_octet
#define ttk_enum() tk_enum
#define ttk_string() tk_string
#define ttk_pointer() tk_pointer
#define tSOMClass() _SOMClass
#define tSOMObject() _SOMObject
#define tSOMClassMgr() _SOMClassMgr
#define tSOMClassMgrObject() SOMClassMgrObject
#define ptrsize() sizeof(char*)
/* Boot sections of daughter .xs files: */
extern XS(boot_DSOM);
extern XS(boot_SOMIr);
MODULE = SOM PACKAGE = SOM PREFIX = t
PROTOTYPES: ENABLE
int
ptrsize()
int
ttk_void()
int
ttk_short()
int
ttk_ushort()
int
ttk_long()
int
ttk_ulong()
int
ttk_float()
int
ttk_double()
int
ttk_char()
int
ttk_boolean()
int
ttk_octet()
int
ttk_enum()
int
ttk_string()
int
ttk_pointer()
SOMClass *
tSOMClass()
SOMClass *
tSOMObject()
SOMClass *
tSOMClassMgr()
SOMObject *
tSOMClassMgrObject()
MODULE = SOM PACKAGE = SOM PREFIX = PSOM_
BOOT:
somEnvironmentNew();
main_ev = somGetGlobalEnvironment();
newXS("SOM::bootstrap_DSOM", boot_DSOM, file);
newXS("SOM::bootstrap_SOMIr", boot_SOMIr, file);
SOMClass *
PSOM_Find_Class(name, major = 0, minor = 0, dll = 0)
char *name;
int major;
int minor;
char *dll;
MODULE = SOM PACKAGE = SOMClassPtr PREFIX = PSOM_
SOMObject *
PSOM_NewObject(classobj)
SOMClass *classobj
MODULE = SOM PACKAGE = SOMObjectPtr PREFIX = _som
SOMClass *
_somGetClass(obj)
SOMObject *obj
char *
_somGetClassName(obj)
SOMObject *obj
MODULE = SOM PACKAGE = SOMObjectPtr PREFIX = PSOM_
int
PSOM_Dispatch0(obj, meth)
SOMObject *obj;
char *meth;
int
PSOM_Dispatch_templ(obj, meth, templ, ...)
SOMObject *obj;
char *meth;
char *templ;
PPCODE:
{
union { short s; unsigned short us; long l; unsigned long ul;
char c; unsigned char uc; float f; double d; char *cp; void *vp;
} ret_buffer, par_buffer;
va_list start_val;
MYsomVaBuf vb;
somToken *ret = 0;
char *t = templ;
int is_oidl = 0;
int i = 3; /* ordinal of a parameter */
somId methId = SOM_IdFromString(meth);
int rc;
SV *retsv;
if (!*t)
croak("A zero length template");
if (*t++ == 'o')
is_oidl = 1;
if (!*t)
croak("No return specifier in a template");
/* Return value: */
switch (*t - tk_shift_) {
case tk_pointer:
case tk_TypeCode:
default:
croak("Do not know how to treat specifier '%c'==%d for return value in '%s'",
(*t ? *t : '?'), (int)(*t - tk_shift_), templ);
case tk_void:
break;
case tk_short:
case tk_ushort:
case tk_long:
case tk_ulong:
case tk_float:
case tk_double:
case tk_char:
case tk_boolean:
case tk_octet:
case tk_enum:
case tk_string:
// case tk_pointer:
ret = (somToken *)&ret_buffer;
}
vb = (MYsomVaBuf)MYsomVaBuf_create(NULL, 0);
if (!vb)
croak("Cannot create VaBuf");
MYsomVaBuf_add(vb, (char *)&obj, tk_pointer);
if (!is_oidl)
MYsomVaBuf_add(vb, (char *)&main_ev, tk_pointer);
while (*++t) {
int type = *t - tk_shift_;
STRLEN n_a;
if (i >= items)
croak("Too few arguments");
switch (type) {
case tk_pointer:
case tk_TypeCode:
default:
croak("Do not know how to treat specifier '%c'==%d for parameter in '%s'",
(*t ? *t : '?'), type, templ);
case tk_short:
par_buffer.s = (short)SvIV(ST(i));
break;
case tk_ushort:
par_buffer.us = (unsigned short)SvIV(ST(i));
break;
case tk_long:
par_buffer.l = (long)SvIV(ST(i));
break;
case tk_ulong:
par_buffer.ul = (unsigned long)SvIV(ST(i));
break;
case tk_float:
par_buffer.f = (float)SvNV(ST(i));
break;
case tk_double:
par_buffer.d = (double)SvNV(ST(i));
break;
case tk_char:
par_buffer.c = (char)SvIV(ST(i));
break;
case tk_boolean:
par_buffer.l = SvTRUE(ST(i));
break;
case tk_octet:
par_buffer.uc = (unsigned char)SvIV(ST(i));
break;
case tk_enum:
par_buffer.ul = (unsigned long)SvIV(ST(i));
break;
case tk_string:
par_buffer.cp = SvPV(ST(i), n_a);
break;
/* case tk_pointer:
par_buffer.vp = (void*)SvPV(ST(i), n_a);
break;*/
}
if (!MYsomVaBuf_add(vb, (char *)&par_buffer, type))
croak("Error while adding to VaBuf, type=%d", type);
i++;
}
if (i != items)
croak("Too many arguments");
MYsomVaBuf_get_valist(vb, &start_val);
rc = MYsomDispatch(
obj, /* target for somDispatch */
ret, /* dispatched method result */
methId, /* the somId for meth */
start_val); /* target and args for _set_msg */
SOMFree(methId);
MYsomVaBuf_destroy(vb);
if (!rc)
croak("Error dispatching a method");
if (!ret)
XSRETURN(0); /* Nothing to return */
retsv = sv_newmortal();
switch (templ[1] - tk_shift_) {
case tk_pointer:
case tk_void:
case tk_TypeCode:
default:
croak("panic: do not know how to treat specifier '%c'==%d for return value in '%s'",
(*t ? *t : '?'), (int)(*t - tk_shift_), templ);
break;
case tk_short:
sv_setiv(retsv, ret_buffer.s);
break;
case tk_ushort:
sv_setuv(retsv, ret_buffer.us);
break;
case tk_long:
sv_setiv(retsv, ret_buffer.l);
break;
case tk_enum:
case tk_ulong:
sv_setuv(retsv, ret_buffer.ul);
break;
case tk_float:
sv_setnv(retsv, ret_buffer.f);
break;
case tk_double:
sv_setnv(retsv, ret_buffer.d);
break;
case tk_char:
sv_setiv(retsv, ret_buffer.c);
break;
case tk_boolean:
case tk_octet:
sv_setuv(retsv, ret_buffer.uc);
break;
case tk_string:
sv_setpv(retsv, ret_buffer.cp);
break;
}
PUSHs(retsv);
}