/**********************************************************************
 
	Copyright (C) 2003 Hirohisa MORI <joshua@nichibun.ac.jp>
 
	This program is free software; you can redistribute it 
	and/or modify it under the terms of the GLOBALBASE 
	Library General Public License (G-LGPL) as published by 

	http://www.globalbase.org/
 
	This program 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.

**********************************************************************/


#include	"xlerror.h"
#include	"xl.h"
#include	"utils.h"

XL_SEXP * xl_OpenInterpreter();

XL_SEXP *
_xl(XL_INTERPRETER ** xlip,XLISP_ENV * env,XL_SEXP * s,int gbtype,
	char * type_mis)
{
XL_SEXP * s_xli;
XL_INTERPRETER * xli;
XL_SEXP * data;
	s_xli = eval(env,get_symbol(l_string(std_cm,"__xli")));
	switch ( get_type(s_xli) ) {
	case XLT_ERROR:
		return s_xli;
	case XLT_PTR:
		xli = s_xli->ptr.ptr;
		break;
	default:
		return 0;
	}
	if ( list_length(s) >= 2 ) {
		data = get_el(s,1);
		if ( get_type(data) != gbtype )
			goto type_missmatch;
		*xlip = xli;
		return data;
	}
	else	return 0;
type_missmatch:
	return get_error(
		s->h.file,
		s->h.line,
		XLE_SEMANTICS_TYPE_MISSMATCH,
		l_string(std_cm,type_mis),
		0);
}

XL_SEXP *
_xl_FormatIndent(XLISP_ENV * env,XL_SEXP * s)
{
XL_SEXP * data;
XL_INTERPRETER * xli;
	data = _xl(&xli,env,s,XLT_INTEGER,"FormatIndent");
	if ( get_type(data) == XLT_ERROR )
		return data;
	if ( data->integer.data )
		xli->ps_flags |= PF_INDENT;
	return 0;
}

XL_SEXP *
_xl_FormatMode(XLISP_ENV * env,XL_SEXP * s)
{
XL_SEXP * data;
XL_INTERPRETER * xli;
	data = _xl(&xli,env,s,XLT_STRING,"FormatMode");
	if ( get_type(data) == XLT_ERROR )
		return data;
	if ( l_strcmp(data->string.data,l_string(std_cm,"lisp")) == 0 ) {
		xli->ps_flags &= ~PFM_FORMAT;
		xli->ps_flags |= PF_LISP;
	}
	else if ( l_strcmp(data->string.data,l_string(std_cm,"xml")) == 0 ) {
		xli->ps_flags &= ~PFM_FORMAT;
		xli->ps_flags |= PF_XML;
	}
	else if ( l_strcmp(data->string.data,l_string(std_cm,"html")) == 0 ) {
		xli->ps_flags &= ~PFM_FORMAT;
		xli->ps_flags |= PF_HTML;
	}
	else return get_error(
		s->h.file,
		s->h.line,
		XLE_PROTO_INV_PARAM,
		l_string(std_cm,"FormatMode"),
		List(	n_get_string("invalid format mode"),
			data,
			-1));
	return 0;
}

XL_SEXP *
_xl_Result(XLISP_ENV * env,XL_SEXP * s)
{
XL_SEXP * data;
XL_INTERPRETER * xli;
	data = _xl(&xli,env,s,XLT_INTEGER,"Result");
	if ( get_type(data) == XLT_ERROR )
		return data;
	xli->result_flag = data->integer.data;
	return 0;
}

XL_SEXP *
_xl_InpDescripter(XLISP_ENV * env,XL_SEXP * s)
{
XL_SEXP * data;
XL_INTERPRETER * xli;

	data = _xl(&xli,env,s,XLT_INTEGER,"InpDescripter");
	if ( get_type(data) == XLT_ERROR )
		return data;
	xli->inp_desc = data->integer.data;
	return 0;
}


XL_SEXP *
_xl_OutDescripter(XLISP_ENV * env,XL_SEXP * s)
{
XL_SEXP * data;
XL_INTERPRETER * xli;

	data = _xl(&xli,env,s,XLT_INTEGER,"OutDescripter");
	if ( get_type(data) == XLT_ERROR )
		return data;
	xli->out_desc = data->integer.data;
	return 0;
}




XL_SEXP *
_xl_ErrDescripter(XLISP_ENV * env,XL_SEXP * s)
{
XL_SEXP * data;
XL_INTERPRETER * xli;

	data = _xl(&xli,env,s,XLT_INTEGER,"ErrDescripter");
	if ( get_type(data) == XLT_ERROR )
		return data;
	xli->err_desc = data->integer.data;
	return 0;
}

XL_SEXP *
set_recv_streams(XL_INTERPRETER * xli,XL_SEXP * s)
{
	switch ( recv_streams_len ) {
	case 0:
	 	return get_error(
			s->h.file,
			s->h.line,
			XLE_PROTO_INV_PARAM,
			l_string(std_cm,
				"RecvStream in OpenInterpreter"),
			n_get_string("No recieved streams"));
	case 1:
		xli->inp = xli->out = recv_streams[0];
		break;
	default:
		xli->inp = recv_streams[0];
		xli->out = recv_streams[1];
		break;
	}
	return 0;
}



XL_SEXP *
_xl_Type(XLISP_ENV * env,XL_SEXP * s)
{
XL_SEXP * data;
XL_INTERPRETER * xli;

	data = _xl(&xli,env,s,XLT_STRING,"Type");
	if ( get_type(data) == XLT_ERROR )
		return data;
	if ( l_strcmp(data->string.data,
			l_string(std_cm,"connect")) == 0 )
		xli->desc_type = XLA_CONNECT;
	else if ( l_strcmp(data->string.data,
			l_string(std_cm,"file")) == 0 )
		xli->desc_type = XLA_FILE;
	else if ( l_strcmp(data->string.data,
			l_string(std_cm,"accept")) == 0 )
		xli->desc_type = XLA_ACCEPT;
	else if ( l_strcmp(data->string.data,
			l_string(std_cm,"stdio")) == 0 )
		xli->desc_type = XLA_STDIO;
	else if ( l_strcmp(data->string.data,
			l_string(std_cm,"ipc")) == 0 )
		xli->desc_type = XLA_IPC;
	else if ( l_strcmp(data->string.data,
			l_string(std_cm,"pipe")) == 0 )
		xli->desc_type = XLA_PIPE;
	else 	return get_error(
			s->h.file,
			s->h.line,
			XLE_PROTO_INV_PARAM,
			l_string(std_cm,"Type in OpenInterpreter"),
			n_get_string("invalid Type"));
	return 0;
}

XL_SEXP *
_xl_Port(XLISP_ENV * env,XL_SEXP * s)
{
XL_SEXP * data;
XL_INTERPRETER * xli;

	data = _xl(&xli,env,s,XLT_INTEGER,"Port");
	if ( get_type(data) == XLT_ERROR )
		return data;
	xli->port = data->integer.data;
	return 0;
}

XL_SEXP *
_xl_IP(XLISP_ENV * env,XL_SEXP * s)
{
XL_SEXP * data;
XL_INTERPRETER * xli;

	data = _xl(&xli,env,s,XLT_INTEGER,"IP");
	if ( get_type(data) == XLT_ERROR )
		return data;
	xli->ip = data->integer.data;
	return 0;
}

XL_SEXP *
_xl_HostName(XLISP_ENV * env,XL_SEXP * s)
{
XL_SEXP * data;
XL_INTERPRETER * xli;

	data = _xl(&xli,env,s,XLT_STRING,"HostName");
	if ( get_type(data) == XLT_ERROR )
		return data;
	xli->hostname = ll_copy_str(data->string.data,1479);
	return 0;
}

XL_SEXP *
_xl_MaxConnection(XLISP_ENV * env,XL_SEXP * s)
{
XL_SEXP * data;
XL_INTERPRETER * xli;
	data = _xl(&xli,env,s,XLT_INTEGER,"MaxConnection");
	if ( get_type(data) == XLT_ERROR )
		return data;
	xli->max_connection = data->integer.data;
	return 0;
}

XL_SEXP *
_xl_InputFileName(XLISP_ENV * env,XL_SEXP * s)
{
XL_SEXP * data;
XL_INTERPRETER * xli;
	data = _xl(&xli,env,s,XLT_STRING,"InputFileName");
	if ( get_type(data) == XLT_ERROR )
		return data;
	xli->input_file_name = ll_copy_str(data->string.data,1478);
	return 0;
}

XL_SEXP *
_xl_OutputFileName(XLISP_ENV * env,XL_SEXP * s)
{
XL_SEXP * data;
XL_INTERPRETER * xli;
	data = _xl(&xli,env,s,XLT_STRING,"OutputFileName");
	if ( get_type(data) == XLT_ERROR )
		return data;
	xli->output_file_name = ll_copy_str(data->string.data,1477);
	return 0;
}

XL_SEXP *
_xl_ErrorFileName(XLISP_ENV * env,XL_SEXP * s)
{
XL_SEXP * data;
XL_INTERPRETER * xli;
	data = _xl(&xli,env,s,XLT_STRING,"ErrorFileName");
	if ( get_type(data) == XLT_ERROR )
		return data;
	xli->error_file_name = ll_copy_str(data->string.data,1476);
	return 0;
}

XL_SEXP *
_xl_ConnectionTimeout(XLISP_ENV * env,XL_SEXP * s)
{
XL_SEXP * data;
int er;
XL_INTERPRETER * xli;
	data = _xl(&xli,env,s,XLT_INTEGER,"ConnectionTimeout");
	if ( get_type(data) == XLT_ERROR )
		return data;
	xli->connection_timeout = conv_unit(&er,
		get_uenv(env),
		data->integer.data,
		data->integer.unit,
		l_string(std_cm,"sec"));
	return 0;
}

XL_SEXP *
_xl_SilentTimeout(XLISP_ENV * env,XL_SEXP * s)
{
XL_SEXP * data;
int er;
XL_INTERPRETER * xli;
	data = _xl(&xli,env,s,XLT_INTEGER,"SilentTimeout");
	if ( get_type(data) == XLT_ERROR )
		return data;
	xli->silent_timeout = conv_unit(&er,
		get_uenv(env),
		data->integer.data,
		data->integer.unit,
		l_string(std_cm,"sec"));
	return 0;
}

XL_SEXP *
_xl_Environment(XLISP_ENV * env,XL_SEXP * s)
{
XL_SEXP * data;
XL_INTERPRETER * xli;
	data = _xl(&xli,env,s,XLT_STRING,"Environment");
	if ( get_type(data) == XLT_ERROR )
		return data;
	if ( l_strcmp(data->string.data,l_string(std_cm,"thisone")) == 0 )
		xli->environment = 0;
	else if ( l_strcmp(data->string.data,l_string(std_cm,"new")) == 0 )
		xli->environment = 1;
	else 
		return get_error(
			s->h.file,
			s->h.line,
			XLE_PROTO_INV_PARAM,
			l_string(std_cm,"Environment"),
			data);
	return 0;
}


XL_SEXP *
_xl_Permission(XLISP_ENV * env,XL_SEXP * s,XLISP_ENV * aenv)
{
int len;
XL_SEXP * param;
XL_SEXP * mode,* mp;
XL_INTERPRETER * xli;
XL_SEXP * ptr;

	mode = eval(env,get_el(s,1));
	switch ( get_type(mode) ) {
	case XLT_ERROR:
		return mode;
	case XLT_PAIR:
		break;
	default:
		goto type_missmatch;
	}
	for ( mp = mode ; get_type(mp) ; mp = cdr(mp) ) {
		switch ( get_type(car(mp)) ) {
		case XLT_ERROR:
			return mp;
		case XLT_STRING:
			break;
		default:
			goto type_missmatch;
		}
	}
	ptr = eval(env,n_get_symbol("__xli"));
	switch ( get_type(ptr) ) {
	case XLT_ERROR:
		return ptr;
	case XLT_PTR:
		xli = ptr->ptr.ptr;
		break;
	default:
		return get_error(
			s->h.file,
			s->h.line,
			XLE_SEMANTICS_TYPE_MISSMATCH,
			l_string(std_cm,"Permission"),
			list(n_get_string(
			"__xli type missmatch"),
				0));
	}
	new_permission_list(xli,mode);
	s = cdr(cdr(s));
	aenv = new_env_pair(aenv,env);
	for ( ; get_type(s) ; s = cdr(s) ) {
		if ( get_type(s) == XLT_ERROR )
			return s;
		param = car(s);
		param = eval(aenv,param);
		if ( get_type(param) == XLT_ERROR )
			return param;
	}
	return 0;
type_missmatch:
	return get_error(
		s->h.file,
		s->h.line,
		XLE_SEMANTICS_TYPE_MISSMATCH,
		l_string(std_cm,"Permission"),
		n_get_string("type missmatch"));
}

XL_SEXP *
_xl_allow_deny(int ap_type,XLISP_ENV * env,XL_SEXP * s)
{
XL_SEXP * type;
XL_INTERPRETER * xli;
XL_SEXP * ptr;
XL_SEXP * domain;
XL_SEXP * ip,* mask;
int _ip,_mask;
	ptr = eval(env,n_get_symbol("__xli"));
	switch ( get_type(ptr) ) {
	case XLT_ERROR:
		return ptr;
	case XLT_PTR:
		xli = ptr->ptr.ptr;
		break;
	default:
		return get_error(
			s->h.file,
			s->h.line,
			XLE_SEMANTICS_TYPE_MISSMATCH,
			l_string(std_cm,"allow/deny"),
			list(n_get_string(
			"__xli type missmatch"),
				0));
	}
	type = get_el(s,1);
	switch ( get_type(type) ) {
	case XLT_ERROR:
		return type;
	case XLT_STRING:
		break;
	default:
		goto typemissmatch;
	}
	if ( l_strcmp(type->string.data,l_string(std_cm,"ip")) == 0 ) {
		ip = get_el(s,2);
		switch ( get_type(ip) ) {
		case XLT_ERROR:
			return ip;
		case XLT_INTEGER:
			_ip = ip->integer.data;
			break;
		case XLT_STRING:
			_ip = inet_addr(n_string(std_cm,ip->string.data));
			break;
		default:
			goto typemissmatch;
		}
		mask = get_el(s,3);
		switch ( get_type(mask) ) {
		case XLT_ERROR:
			return mask;
		case XLT_INTEGER:
			_mask = mask->integer.data;
			break;
		case XLT_STRING:
			_mask = inet_addr(n_string(std_cm,mask->string.data));
			break;
		default:
			goto typemissmatch;
		}
		insert_access_list(
			&xli->pl_tail->ap,
			_ip,_mask,0,ap_type);
		return 0;
	}
	else if ( l_strcmp(type->string.data,l_string(std_cm,"domain"))
						== 0 ) {
		domain = get_el(s,2);
		switch ( get_type(domain) ) {
		case XLT_ERROR:
			return domain;
		case XLT_STRING:
			break;
		default:
			goto typemissmatch;
		}
		insert_access_list(
			&xli->pl_tail->ap,
			0,0,n_string(std_cm,domain->string.data),ap_type);
		return 0;
	}
	else if ( l_strcmp(type->string.data,l_string(std_cm,"all")) == 0 ) {
		insert_access_list(
			&xli->pl_tail->ap,
			0,0,0,ap_type);
		return 0;
	}
	else {
		return get_error(
			s->h.file,
			s->h.line,
			XLE_PROTO_INV_PARAM,
			l_string(std_cm,"allow/deny"),
			list(n_get_string("invalid type"),
				type,
				0));
	}
typemissmatch:
	return get_error(
		s->h.file,
		s->h.line,
		XLE_SEMANTICS_TYPE_MISSMATCH,
		l_string(std_cm,"allow/deny"),
		list(n_get_string("type missmatch"),
			0));
}

XL_SEXP *
_xl_Allow(XLISP_ENV * env,XL_SEXP * s)
{
	return _xl_allow_deny(AP_ALLOW,env,s);
}

XL_SEXP *
_xl_Deny(XLISP_ENV * env,XL_SEXP * s)
{
	return _xl_allow_deny(AP_DENY,env,s);
}

void
init_Permission(XLISP_ENV * env)
{
XLISP_ENV * args_env;
	args_env = new_env(0);
	set_env(args_env,l_string(std_cm,"Allow"),
		get_func_prim(_xl_Allow,FO_APPLICATIVE,0,2,4));
	set_env(args_env,l_string(std_cm,"Deny"),
		get_func_prim(_xl_Deny,FO_APPLICATIVE,0,2,4));

	set_env(env,l_string(std_cm,"Permission"),
		get_func_prim(_xl_Permission,FO_NORMAL,args_env,2,-1));
}

void
init_OpenInterpreter(XLISP_ENV * env)
{
XLISP_ENV * args_env;
	args_env = new_env(0);

	set_env(args_env,l_string(std_cm,"Port"),
		get_func_prim(_xl_Port,FO_APPLICATIVE,0,2,2));
	set_env(args_env,l_string(std_cm,"IP"),
		get_func_prim(_xl_IP,FO_APPLICATIVE,0,2,2));
	set_env(args_env,l_string(std_cm,"HostName"),
		get_func_prim(_xl_HostName,FO_APPLICATIVE,0,2,2));
	set_env(args_env,l_string(std_cm,"MaxConnection"),
		get_func_prim(_xl_MaxConnection,FO_APPLICATIVE,0,2,2));
	set_env(args_env,l_string(std_cm,"InputFileName"),
		get_func_prim(_xl_InputFileName,FO_APPLICATIVE,0,2,2));
	set_env(args_env,l_string(std_cm,"OutputFileName"),
		get_func_prim(_xl_OutputFileName,FO_APPLICATIVE,0,2,2));
	set_env(args_env,l_string(std_cm,"ErrorFileName"),
		get_func_prim(_xl_ErrorFileName,FO_APPLICATIVE,0,2,2));
	set_env(args_env,l_string(std_cm,"ConnectionTimeout"),
		get_func_prim(_xl_ConnectionTimeout,FO_APPLICATIVE,0,
					2,2));
	set_env(args_env,l_string(std_cm,"SilentTimeout"),
		get_func_prim(_xl_SilentTimeout,FO_APPLICATIVE,0,2,2));
	set_env(args_env,l_string(std_cm,"Environment"),
		get_func_prim(_xl_Environment,FO_APPLICATIVE,0,2,2));
	set_env(args_env,l_string(std_cm,"InputDescripter"),
		get_func_prim(_xl_InpDescripter,FO_APPLICATIVE,0,2,2));
	set_env(args_env,l_string(std_cm,"OutputDescripter"),
		get_func_prim(_xl_OutDescripter,FO_APPLICATIVE,0,2,2));
	set_env(args_env,l_string(std_cm,"ErrorDescripter"),
		get_func_prim(_xl_ErrDescripter,FO_APPLICATIVE,0,2,2));
	set_env(args_env,l_string(std_cm,"Type"),
		get_func_prim(_xl_Type,FO_APPLICATIVE,0,2,2));
	set_env(args_env,l_string(std_cm,"Result"),
		get_func_prim(_xl_Result,FO_APPLICATIVE,0,2,2));
	set_env(args_env,l_string(std_cm,"FormatMode"),
		get_func_prim(_xl_FormatMode,FO_APPLICATIVE,0,2,2));
	set_env(args_env,l_string(std_cm,"FormatIndent"),
		get_func_prim(_xl_FormatIndent,FO_APPLICATIVE,0,2,2));

	init_Permission(args_env);

	set_env(env,l_string(std_cm,"OpenInterpreter"),
		get_func_prim(xl_OpenInterpreter,FO_NORMAL,
				args_env,3,-1));
}


XL_SEXP *
xl_OpenInterpreter(XLISP_ENV * env,XL_SEXP * s,XLISP_ENV * args_env)
{
XL_SEXP * e, * ret;
XL_SEXP * type;
XL_SEXP * opt;
XLISP_ENV * ee, * ee2, * e_env;
XL_INTERPRETER * xli;
XL_SEXP * type_mis;
int a_type;
int id;

	type = eval(env,get_el(s,1));
	switch ( get_type(type) ) {
	case XLT_ERROR:
		return type;
	case XLT_STRING:
		break;
	default:
		type_mis = 
			n_get_string("first argment(interpreter type)");
		goto type_missmatch;
	}
	e = eval(env,get_el(s,2));
	switch ( get_type(e) ) {
	case XLT_ERROR:
		return e;
	case XLT_NULL:
		e_env = 0;
		break;
	case XLT_ENV:
		e_env = e->env.data;
		break;
	default:
		type_mis = n_get_string(
			"first argment(interpreter environment)");
		goto type_missmatch;
	}
	xli = new_xl_interpreter();
	if ( l_strcmp(type->string.data,l_string(std_cm,"stdio")) == 0 )
		xli->a_type = XLA_STDIO;
	else if ( l_strcmp(type->string.data,
			l_string(std_cm,"file")) == 0 )
		xli->a_type = XLA_FILE;
	else if ( l_strcmp(type->string.data,
			l_string(std_cm,"accept")) == 0 )
		xli->a_type = XLA_ACCEPT;
	else if ( l_strcmp(type->string.data,
			l_string(std_cm,"connect")) == 0 )
		xli->a_type = XLA_CONNECT;
	else if ( l_strcmp(type->string.data,
			l_string(std_cm,"ipc")) == 0 )
		xli->a_type = XLA_IPC;
	else if ( l_strcmp(type->string.data,
			l_string(std_cm,"descripter")) == 0 )
		xli->a_type = XLA_DESCRIPTER;
	else if ( l_strcmp(type->string.data,
			l_string(std_cm,"pipe")) == 0 ) {
		xli->a_type = XLA_PIPE;
		ret = set_recv_streams(xli,s);
		if ( get_type(ret) == XLT_ERROR )
			return ret;
	}
	else {
		goto invalid_type;
	}
	xli->env = e_env;
	ee = new_env(env);
	set_env(ee,l_string(std_cm,"__xli"),
		get_ptr(xli,0));
	ee2 = new_env_pair(args_env,ee);
	opt = cdr(cdr(cdr(s)));
	for ( ; get_type(opt) ; opt = cdr(opt) ) {
		ret = eval(ee2,car(opt));
		if ( get_type(ret) == XLT_ERROR )
			return ret;
	}
	id = setup_i(xli);
	if ( id < 0 )
		goto access_error;
	return get_integer(id,0);
type_missmatch:
	return get_error(
		s->h.file,
		s->h.line,
		XLE_SEMANTICS_TYPE_MISSMATCH,
		l_string(std_cm,"OpenInterpreter"),
		type_mis);
invalid_type:
	return get_error(
		s->h.file,
		s->h.line,
		XLE_PROTO_INV_PARAM,
		l_string(std_cm,"OpenInterpreter"),
		n_get_string("interpreter accept type"));
access_error:
	return get_error(
		s->h.file,
		s->h.line,
		 XLE_PROTO_ACCESS_STREAM,
		l_string(std_cm,"OpenInterpreter"),
		n_get_string("cannot access the stream"));
}


