/**********************************************************************
 
	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.

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


#define STREAM_LIB

#include	<stdlib.h>
#include	"memory_debug.h"
#include	"xl.h"
#include	"xlerror.h"

/*
([Shell pipe="on/off" cmdout="on/off"] "command" "argment" ....)
*/

#define BUF_SIZE	100

XL_SEXP * xl_Shell();
XL_SEXP * xl_Export();

void
init_Shell(XLISP_ENV * env)
{
	set_env(env,l_string(std_cm,"Shell"),
		get_func_prim(xl_Shell,FO_APPLICATIVE,0,2,-1));
}

void
init_Export(XLISP_ENV * env)
{
	set_env(env,l_string(std_cm,"Export"),
		get_func_prim(xl_Export,FO_NORMAL,0,2,-1));
}


XL_SEXP *
Shell_target(L_CHAR * target,L_CHAR * eval_type,
	     XLISP_ENV * env,XL_SEXP * s)
{
STREAM * pip[2];
XL_INTERPRETER * xli;
int id;
XL_SEXP * ret, * ret_s;
void gc_gb_sexp();
XL_SEXP * chain;
STREAM * st[3];
char close_flags[3];
char * argv[3];
char * _target;
extern L_CHAR * script_path;
XL_SEXP * send;

	s_open_fpipe(pip);
	st[0] = pip[0];
	st[1] = 0;
	close_flags[0] = 1;
	close_flags[1] = 0;
	_target = ln_copy_str(std_cm,target);
	argv[0] = _target;
	argv[1] = 0;

	launch_proc(_target,argv,st,close_flags,0,0);
	d_f_ree(_target);
	xli = new_xl_interpreter();
	xli->a_type = XLA_PIPE;
	xli->env = env;
	xli->inp = pip[1];
	xli->out = pip[1];
	xli->err = 0;
	xli->environment = 1;
	id = setup_i(xli);
	if ( id < 0 ) {
		s_close(pip[0]);
		s_close(pip[1]);
		return get_error(
			s->h.file,
			s->h.line,
			XLE_PROTO_USER_ERROR,
			l_string(std_cm,"Shell"),
			List(	n_get_string("cannot open the pipe"),
				get_integer(id,0),
				-1));
	}
	gc_push(0,0,"Shell_target");
	chain = n_get_symbol("PrintChain");
	set_attribute(chain,
		l_string(std_cm,"sync"),
		l_string(std_cm,"entry"));
	ret = remote_query(id,env,0,List(chain,-1));
	if ( get_type(ret) == XLT_ERROR ) {
		gc_pop(ret,gc_gb_sexp);
		goto end;
	}
	if ( script_path ) {
		ret = remote_query(id,env,0,List(
			n_get_symbol("SetScriptPath"),
			get_string(script_path),
			-1));
	}
	gc_pop(ret,gc_gb_sexp);

	if ( get_type(ret) == XLT_ERROR )
		goto end;

	s = cdr(s);
	for ( ; get_type(s) == XLT_PAIR ; s = cdr(s) ) {
		gc_push(0,0,"Shell_target");
		send = gb_quote_trace(env,car(s),eval_type);
		ret = remote_query(id,env,0,send);
		gc_pop(ret,gc_gb_sexp);
		if ( get_type(ret) == XLT_ERROR )
			break;
	}
	gc_push(0,0,"Shell_target");
	chain = n_get_symbol("PrintChain");
	set_attribute(chain,
		l_string(std_cm,"sync"),
		l_string(std_cm,"exit"));
	ret_s = remote_query(id,env,0,List(chain,-1));
	get_type(ret_s);
	ret_s = remote_query(id,env,0,List(n_get_symbol("Exit"),-1));
	gc_pop(0,0);

end:

	close_interpreter(id);
	return ret;
}


XL_SEXP * 
xl_Export(XLISP_ENV * env,XL_SEXP * s,XLISP_ENV * a_env,XL_SYM_FIELD * sf)
{
L_CHAR * target;
L_CHAR * type, * _type;
XL_SEXP * ret;
	target = get_sf_attribute(sf,l_string(std_cm,"target"));
	if ( target == 0 ) {
		return get_error(
			s->h.file,
			s->h.line,
			XLE_PROTO_INV_PARAM,
			l_string(std_cm,"Export"),
			List(	n_get_string("target is required "),
				-1));
	}
	type = get_sf_attribute(sf,l_string(std_cm,"type"));
	if ( type == 0 )
		_type = type = nl_copy_str(std_cm,"direct");
	else	_type = 0;
	ret = Shell_target(target,type,env,s);
	if ( _type )
		d_f_ree(type);
	return ret;
}

XL_SEXP * 
xl_Shell(XLISP_ENV * env,XL_SEXP * s,XLISP_ENV * a_env,XL_SYM_FIELD * sf)
{
XL_SEXP * a;
XL_SEXP * b;
L_CHAR * cmd;
int len,len2;
int cnt;
int pipe_flag;
int cmdout_flag;
STREAM * in,* out,* err;
char * buf,*err_buf;
int size,er,ptr;
XL_SEXP * ret;
int zero_cnt;
L_CHAR * target;

	pipe_flag = 0;
	cmdout_flag = 0;
	target = 0;
	for ( ; sf ; sf = sf->next ) {
		if ( l_strcmp(sf->name,l_string(std_cm,"pipe")) == 0 ) {
			if ( l_strcmp(sf->data,l_string(std_cm,"on")) == 0 ) {
				pipe_flag = 1;
			}
			else {
				pipe_flag = 0;
			}
		}
		else if ( l_strcmp(sf->name,l_string(std_cm,"cmdout")) == 0 ) {
			if ( l_strcmp(sf->data,l_string(std_cm,"on")) == 0 ) {
				cmdout_flag = 1;
			}
			else {
				cmdout_flag = 0;
			}
		}
	}

	cmd = d_alloc(sizeof(L_CHAR),12);
	cmd[0] = 0;
	len = 0;
	cnt = 1;
	for ( a = cdr(s) ; get_type(a) ; a = cdr(a) , cnt ++ ) {
		b = car(a);
		switch ( get_type(b) ) {
		case XLT_ERROR:
			return b;
		case XLT_STRING:
			break;
		default:
			goto typemissmatch;
		}
		len2 = l_strlen(b->string.data);
		cmd = d_re_alloc(cmd,(len+len2+1)*sizeof(L_CHAR));
		l_strcpy(&cmd[len],b->string.data);
		len += len2;
	}
	if ( cmdout_flag )
		ss_printf("%s\n",n_string(std_cm,cmd));
	if ( pipe_flag == 0 ) {
		launch_proc_stdio(0,0,0,n_string(std_cm,cmd));
		d_f_ree(cmd);
		return 0;
	}
	else {
		launch_proc_stdio(&in,&out,&err,n_string(std_cm,cmd));
		buf = d_alloc(BUF_SIZE,620);
		size = BUF_SIZE;
		ptr = 0;
		for ( ; ; ) {
			er = s_read(out,&buf[ptr],BUF_SIZE);
			if ( er <= 0 )
				break;
			buf[ptr+er] = 0;
			if ( cmdout_flag )
				ss_printf("%s",&buf[ptr]);
			ptr += er;
			size += BUF_SIZE+1;
			buf = d_re_alloc(buf,size);
		}
		if ( ptr >= size )
			buf = d_re_alloc(buf,size+1);
		buf[ptr] = 0;

		err_buf = d_alloc(BUF_SIZE,621);
		size = BUF_SIZE;
		ptr = 0;
		for ( ; ; ) {
			er = s_read(err,&err_buf[ptr],BUF_SIZE);
			if ( er <= 0 )
				break;
			ptr += er;
			size += BUF_SIZE;
			err_buf = d_re_alloc(err_buf,size);
		}
		if ( ptr >= size )
			err_buf = d_re_alloc(err_buf,size+1);
		err_buf[ptr] = 0;

		if ( err_buf[0] ) {
			ret = get_error(
				s->h.file,
				s->h.line,
				XLE_PROTO_USER_ERROR,
				l_string(std_cm,"Shell"),
				list(	get_string(l_string(std_cm,buf)),
					get_string(l_string(std_cm,err_buf)),
					0));
		}
		else {
			ret = get_string(l_string(std_cm,buf));
		}
		s_close(in);
		s_close(out);
		s_close(err);
		d_f_ree(cmd);
		d_f_ree(buf);
		d_f_ree(err_buf);
		return ret;
	}
typemissmatch:
	return get_error(
		s->h.file,
		s->h.line,
		XLE_SEMANTICS_TYPE_MISSMATCH,
		l_string(std_cm,"Shell"),
		list(	n_get_string("type missmatch at argment "),
			get_integer(cnt,0),
			0));
}
