glish.xs

linux 下的源代码分析阅读器 red hat公司新版

/* terrible hacks for Sun's Cfront compiler */
#define true XTRUE
#define false XFALSE
#define __attribute__(x)

/*
**  Copyright 1995 Darrell Schiebel ([e-mail]).  All rights reserved.
**
** This software is not subject to any license of the American Telephone
** and Telegraph Company or of the Regents of the University of California.
**
** Permission is granted to anyone to use this software for any purpose on
** any computer system, and to alter it and redistribute it freely, subject
** to the following restrictions:
** 1. The author is not responsible for the consequences of use of this
**    software, no matter how awful, even if they arise from flaws in it.
** 2. The origin of this software must not be misrepresented, either by
**    explicit claim or by omission.  Since few users ever read sources,
**    credits must appear in the documentation.
** 3. Altered versions must be plainly marked as such, and must not be
**    misrepresented as being the original software.  Since few users
**    ever read sources, credits must appear in the documentation.
** 4. This notice may not be removed or altered.
*/

#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"

#include <Glish/Value.h>
#include <Glish/Client.h>
#include <string.h>

/* Internal Global Data */
static Client *client = 0;

extern "C" void  boot_Glish (CV*);

static Value* pv2gv(SV *, glish_type = TYPE_ERROR);
static SV* gv2pv(const Value *, glish_type&);
static SV* gv2pv_hash(const recordptr);
static SV* gv2pv_hash(const recordptr, glish_type &);

#define BITS_PER_BYTE	8

// Error field for reporting errors to Perl
#define ERRORs		"error"

// Complex fields for returning Glish complex
// to Perl.
#define REALs		"real"
#define IMAGs		"imag"

// Type prefix for adding Glish types as fields
// in Perl hashes
#define ATTRs		"attr*"
#define TYPEs		"type*"
#define TY_AT_len	5

#define INITIAL_STR_len		256
#define INITIAL_ARRAY_len	128

#define COMMA(x) ,x

#/***************************************************
#* Provide the hook for auto creation of the        *
#* glish_type functions, e.g. TYPE_INT, TYPE_BOOL,  *
#* etc.                                             *
#***************************************************/
static int
type(char *name)
	{
	errno = 0;
	if ( strlen(name) >= 6 )
		switch (name[5])
			{
			case 'I':
				if (strEQ(name, "TYPE_INT"))
					return TYPE_INT;
				break;
			case 'C':
				if (strEQ(name, "TYPE_COMPLEX"))
					return TYPE_COMPLEX;
				break;
			case 'E':
				if (strEQ(name, "TYPE_ERROR"))
					return TYPE_ERROR;
				break;
			case 'R':
				if (strEQ(name, "TYPE_RECORD"))
					return TYPE_RECORD;
				break;
			case 'F':
				if (strEQ(name, "TYPE_FLOAT"))
					return TYPE_FLOAT;
				break;
			case 'B':
				if (strEQ(name, "TYPE_BOOL"))
					return TYPE_BOOL;
				if (strEQ(name, "TYPE_BYTE"))
					return TYPE_BYTE;
				break;
			case 'D':
				if (strEQ(name, "TYPE_DOUBLE"))
					return TYPE_DOUBLE;
				if (strEQ(name, "TYPE_DCOMPLEX"))
					return TYPE_DCOMPLEX;
				break;
			case 'S':
				if (strEQ(name, "TYPE_STRING"))
					return TYPE_STRING;
				if (strEQ(name, "TYPE_SHORT"))
					return TYPE_SHORT;
				break;
			}

	errno = EINVAL;
	return 0;
	}

#/***************************************************
#* Create an empty Glish vector                     *
#***************************************************/
static Value*
empty_glish_value()
	{
	int i = 0;
	Value *gv = new Value( &i, 0, COPY_ARRAY );
	return gv;
	}

#/***************************************************
#* get glish_type given an SV*                      *
#***************************************************/
static glish_type
get_type(const SV *val)
	{
	if ( ! val )
		return TYPE_ERROR;
	if (SvROK(val)) return TYPE_REF;
	if (SvIOKp(val)) return TYPE_INT;
	if (SvNOKp(val)) return TYPE_DOUBLE;
	if (SvPOKp(val)) return TYPE_STRING;
	return TYPE_ERROR;
	}

#/***************************************************
#* get glish_type given an IV                       *
#***************************************************/
static glish_type
get_type(IV type)
	{
	switch( type )
		{
		case TYPE_BOOL: return TYPE_BOOL;
		case TYPE_BYTE: return TYPE_BYTE;
		case TYPE_SHORT: return TYPE_SHORT;
		case TYPE_INT: return TYPE_INT;
		case TYPE_FLOAT: return TYPE_FLOAT;
		case TYPE_DOUBLE: return TYPE_DOUBLE;
		case TYPE_STRING: return TYPE_STRING;
		case TYPE_RECORD: return TYPE_RECORD;
		case TYPE_COMPLEX: return TYPE_COMPLEX;
		case TYPE_DCOMPLEX: return TYPE_DCOMPLEX;
		default: return TYPE_ERROR;
		}
	return TYPE_ERROR;
	}

#/***************************************************
#* Glish vector -> Perl scalar, array or hash       *
#*                                                  *
#* The hash is used for complex numbers             *
#***************************************************/
static SV*
gv2pv_array(const Value *array, glish_type &type )
	{
	SV *r;

#define gv2pv_scalar_array_action(ID,GTYPE,PTYPE,typename,accessor,pctor,extra)\
	case GTYPE:							\
		{							\
		type = ID;						\
		typename val = array->accessor();			\
		r = pctor((PTYPE) val extra);				\
		}							\
		break;
		
#define gv2pv_array_action(ID,GTYPE,PTYPE,typename,accessor,pctor,extra)\
	case GTYPE:							\
		{							\
		AV *ret = newAV();					\
		type = ID;						\
		typename *ary = array->accessor();			\
		for (I32 i = 0; i < array->Length(); i++)		\
			{						\
			av_store(ret,i,pctor((PTYPE) ary[i] extra ));	\
			}						\
		r = newRV((SV*) ret);					\
		}							\
		break;

#define gv2pv_complex_array_action(ID,SUBID,GTYPE,PTYPE,typename,accessor)\
	case GTYPE:							\
		{							\
		HV *ret = newHV();					\
		AV *real = newAV();					\
		AV *imag = newAV();					\
		type = ID;						\
		typename *cmpx = array->accessor();			\
		for (I32 i = 0; i < array->Length(); i++)		\
			{						\
			av_store(real,i,newSVnv((PTYPE) cmpx[i].r));	\
			av_store(imag,i,newSVnv((PTYPE) cmpx[i].i ));	\
			}						\
		hv_store(ret,REALs,strlen(REALs),newRV((SV*)real),0);	\
		hv_store(ret,TYPEs REALs,strlen(TYPEs REALs),newSViv((IV)SUBID),0);\
		hv_store(ret,IMAGs,strlen(IMAGs),newRV((SV*)imag),0);	\
		hv_store(ret,TYPEs IMAGs,strlen(TYPEs IMAGs),newSViv((IV)SUBID),0);\
		r = newRV((SV*) ret);					\
		}							\
		break;

#define gv2pv_scalar_array_action(ID,GTYPE,PTYPE,typename,accessor,pctor,extra)\
	case GTYPE:							\
		{							\
		type = ID;						\
		typename val = array->accessor();			\
		r = pctor((PTYPE) val extra);				\
		}							\
		break;

#define gv2pv_scalar_complex_array_action(ID,SUBID,GTYPE,PTYPE,typename,accessor)\
	case GTYPE:							\
		{							\
		HV *ret = newHV();					\
		type = ID;						\
		typename cmpx = array->accessor();			\
		/*sv_2mortal((SV*)ret);*/				\
		hv_store(ret,REALs,strlen(REALs),newSVnv(cmpx.r),0);	\
		hv_store(ret,TYPEs REALs,strlen(TYPEs REALs),newSViv(SUBID),0);\
		hv_store(ret,IMAGs,strlen(IMAGs),newSVnv(cmpx.i),0);	\
		hv_store(ret,TYPEs IMAGs,strlen(TYPEs IMAGs),newSViv(SUBID),0);\
		r = newRV((SV*) ret);					\
		}							\
		break;
		
	int length = array->Length();
	if ( length > 1 )
		{
		switch (array->Type())
			{
			gv2pv_array_action(TYPE_BOOL,TYPE_BOOL,IV,glish_bool,BoolPtr,newSViv,)
			gv2pv_array_action(TYPE_BYTE,TYPE_BYTE,IV,byte,BytePtr,newSViv,)
			gv2pv_array_action(TYPE_SHORT,TYPE_SHORT,IV,short,ShortPtr,newSViv,)
			gv2pv_array_action(TYPE_INT,TYPE_INT,IV,int,IntPtr,newSViv,)
			gv2pv_array_action(TYPE_FLOAT,TYPE_FLOAT,double,float,FloatPtr,newSVnv,)
			gv2pv_array_action(TYPE_DOUBLE,TYPE_DOUBLE,double,double,DoublePtr,newSVnv,)
			gv2pv_array_action(TYPE_STRING,TYPE_STRING,char*,charptr,StringPtr,
					newSVpv,COMMA(strlen(ary[i])))
			gv2pv_complex_array_action(TYPE_COMPLEX,TYPE_FLOAT,TYPE_COMPLEX,double,complex,ComplexPtr)
			gv2pv_complex_array_action(TYPE_DCOMPLEX,TYPE_DOUBLE,TYPE_DCOMPLEX,double,dcomplex,DcomplexPtr)
			default:
				{
				AV *ret = newAV();
				type=TYPE_ERROR;
				char *err_str = "Bad type in Glish.xs/gv2pv_array";
				av_store(ret,0,newSVpv(err_str,strlen(err_str)));
				r = newRV((SV*) ret);
				}
			}
		}
	else if ( length == 1 )
		{
		switch (array->Type())
			{
			gv2pv_scalar_array_action(TYPE_BOOL,TYPE_BOOL,IV,glish_bool,BoolVal,newSViv,)
			gv2pv_scalar_array_action(TYPE_BYTE,TYPE_BYTE,IV,byte,ByteVal,newSViv,)
			gv2pv_scalar_array_action(TYPE_SHORT,TYPE_SHORT,IV,short,ShortVal,newSViv,)
			gv2pv_scalar_array_action(TYPE_INT,TYPE_INT,IV,int,IntVal,newSViv,)
			gv2pv_scalar_array_action(TYPE_FLOAT,TYPE_FLOAT,double,float,FloatVal,newSVnv,)
			gv2pv_scalar_array_action(TYPE_DOUBLE,TYPE_DOUBLE,double,double,DoubleVal,newSVnv,)
			gv2pv_scalar_array_action(TYPE_STRING,TYPE_STRING,char*,charptr*,StringPtr,
					newSVpv,[0] COMMA(strlen(val[0])))
			gv2pv_scalar_complex_array_action(TYPE_COMPLEX,TYPE_FLOAT,TYPE_COMPLEX,double,complex,ComplexVal)
			gv2pv_scalar_complex_array_action(TYPE_DCOMPLEX,TYPE_DOUBLE,TYPE_DCOMPLEX,double,dcomplex,DcomplexVal)
			default:
				{
				AV *ret = newAV();
				type=TYPE_ERROR;
				char *err_str = "Bad type in Glish.xs/gv2pv_array";
				av_store(ret,0,newSVpv(err_str,strlen(err_str)));
				r = newRV((SV*) ret);
				}
			}

		}
	else
		{
		AV *ret = newAV();
		r = newRV((SV*) ret);
		type = array->Type();
		}

	return r;
	}

#/***************************************************
#* Glish record -> Perl hash                        *
#***************************************************/
static SV*
gv2pv_hash(const recordptr rptr, glish_type &type)
	{
	HV *ret = newHV();
	IterCookie *c = rptr->InitForIteration();
	const Value *member;
	glish_type member_type;
	const char *key;

	type = TYPE_RECORD;

	static int str_len = INITIAL_STR_len;
	static char *type_str = (char*)malloc(str_len*sizeof(char));

	while ( member = rptr->NextEntry( key, c) )
		{
		const attributeptr attr = member->AttributePtr();
		SV *val = gv2pv(member,member_type);
		int key_len = strlen(key);
		hv_store(ret,(char *)key,key_len,val,0);
		if ( key_len + TY_AT_len+1 > str_len )
			{
			while (key_len + TY_AT_len+1 > str_len) str_len *= 2;
			type_str = (char*)realloc((void*)type_str,str_len*sizeof(char));
			}
		strcpy(type_str,TYPEs);
		strcat(type_str,key);
		hv_store(ret,type_str,key_len+TY_AT_len,
			newSViv(member_type),0);
		if ( attr )
			{
			SV *svattr = gv2pv_hash(attr);
			strcpy(type_str,ATTRs);
			strcat(type_str,key);
			hv_store(ret,type_str,key_len+TY_AT_len,svattr,0);
			}
		}
	SV *r = newRV((SV*) ret);
	return r;
	}

#/***************************************************
#* Glish record -> Perl hash                        *
#***************************************************/
static SV*
gv2pv_hash(const recordptr rptr)
	{
	glish_type tmp_type;
	return gv2pv_hash(rptr,tmp_type);
	}

#/***************************************************
#* Glish record -> Perl hash                        *
#***************************************************/
static SV*
gv2pv_hash(const Value *hash, glish_type &type)
	{
	if ( hash->Type() == TYPE_RECORD )
		{
		const recordptr rptr = hash->RecordPtr();
		return gv2pv_hash(rptr,type);
		}
	else
		{
		HV *ret = newHV();
		type=TYPE_ERROR;
		char *err_str = "Bad type in Glish.xs/gv2pv_hash";
		hv_store(ret,ERRORs,strlen(ERRORs),
			newSVpv(err_str,strlen(err_str)),0);
		SV *r = newRV((SV*) ret);
		return r;
		}
	}

#/***************************************************
#* Convert a Glish value to Perl value              *
#***************************************************/
static SV*
gv2pv(const Value *val,glish_type &type)
	{
	if ( val->IsRef() )
		return gv2pv( val->Deref(),type);

	if ( val->Type() == TYPE_RECORD )
		return gv2pv_hash(val,type);
	else
		return gv2pv_array(val,type);
	}

#/***************************************************
#* Perl hash -> Glish record or vector.             *
#***************************************************/
static Value*
pv2gv_hash(HV *hash, glish_type type)
	{
	switch (type)
		{

#define pv2gv_hash_real_action(TYPE,BUILTINs)			\
	case TYPE:						\
		{						\
		SV **rp = hv_fetch(hash,REALs,strlen(REALs),0);	\
		if ( rp )					\
			return pv2gv(*rp,BUILTINs);		\
		else						\
			return empty_glish_value();		\
		}						\
		break;

#define pv2gv_hash_complex_action(TYPE,BUILTINs,builtin,subtype,accessor)\
	case TYPE:							\
		{							\
		SV **rp = hv_fetch(hash,REALs,strlen(REALs),0);		\
		SV **ip = hv_fetch(hash,IMAGs,strlen(IMAGs),0);		\
		if ( rp || ip )						\
			{						\
			Value *realv = 0;				\
			Value *imagv = 0;				\
			if (rp)	realv = pv2gv(*rp,BUILTINs);		\
			if (ip)	imagv = pv2gv(*ip,BUILTINs);		\
			int len = realv ? realv->Length() : 0;		\
			len = imagv ? imagv->Length() > len ? len : 	\
					imagv->Length() : len;		\
			builtin *ret = new builtin[len];		\
									\
			subtype *real = realv ? realv->accessor() : 0;	\
			subtype *imag = imagv ? imagv->accessor() : 0;	\
									\
			for (int cnt = 0; cnt < len; cnt++)		\
				{					\
				ret[cnt].r = real ? real[cnt] : 0;	\
				ret[cnt].i = imag ? imag[cnt] : 0;	\
				}					\
									\
			Value *ret_val = new Value(ret,len);		\
									\
			if (realv)					\
				Unref(realv);				\
			if (imagv)					\
				Unref(imagv);				\
									\
			return ret_val;					\
			}						\
		else							\
			return empty_glish_value();			\
		}							\
		break;

pv2gv_hash_complex_action(TYPE_COMPLEX,TYPE_FLOAT,complex,float,FloatPtr)
pv2gv_hash_complex_action(TYPE_DCOMPLEX,TYPE_DOUBLE,dcomplex,double,DoublePtr)

pv2gv_hash_real_action(TYPE_INT,TYPE_INT)
pv2gv_hash_real_action(TYPE_SHORT,TYPE_SHORT)
pv2gv_hash_real_action(TYPE_BYTE,TYPE_BYTE)
pv2gv_hash_real_action(TYPE_FLOAT,TYPE_FLOAT)
pv2gv_hash_real_action(TYPE_DOUBLE,TYPE_DOUBLE)
pv2gv_hash_real_action(TYPE_BOOL,TYPE_BOOL)

		default:
			{
			hv_iterinit(hash);

			// Used !across! recursive calls to this function
			static int offset = 0;
			static int hash_len = INITIAL_ARRAY_len;
			static const char **keys = (const char**)malloc(hash_len*sizeof(char*));
			static I32 *key_lens = (I32*)malloc(hash_len*sizeof(I32));

			// !Not! used across recursive calls to this function
			static int str_len = INITIAL_STR_len;
			static char *type_str = (char*)malloc(str_len*sizeof(char));

			HE *cur;

			// must maintain offset into the static list of keys becausee
			// this function is called recursively...
			int myoff = offset;
			for (int X = 0; cur = hv_iternext(hash);X++)
				{
				if ( X >= hash_len - myoff )
					{
					hash_len *= 2;
					keys = (const char**)realloc((void*)keys,hash_len*sizeof(char*));
					key_lens = (I32*)realloc((void*)key_lens,hash_len*sizeof(I32));
					}
				keys[myoff+X] = hv_iterkey(cur,&key_lens[myoff+X]);
				if ( key_lens[myoff+X] + TY_AT_len+1 > str_len )
					{
					while (key_lens[myoff+X] + TY_AT_len+1 > str_len) str_len *= 2;
					type_str = (char*)realloc((void*)type_str,str_len*sizeof(char));
					}
				}

			offset += X;			// Advance stack pointer
			Value *ret = create_record();
			for (int XX = 0; XX < X; XX++)
				{
				if ( strncmp(keys[myoff+XX],TYPEs,TY_AT_len) &&
				     strncmp(keys[myoff+XX],ATTRs,TY_AT_len) )