/**********************************************************************
 
	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	<stdio.h>
#include	<fcntl.h>
#include	"xl.h"
#include	"xlerror.h"

/*
(save "filename" <int:open_mode> <int:access_mode> "raw/gblisp" <list:datalist>)
*/

int
gb_save_write(STREAM * st,XL_SEXP * s)
{
int size,er;
char * ptr;
	ptr = s->raw.data;
	size = s->raw.size;
	for ( ; size ; ) {
		er = s_write(st,ptr,size);
		if ( er < 0 )
			return -1;
		size -= er;
		ptr += er;
	}
	mfree(s->raw.data);
	s->raw.data = 0;
	return 0;
}

XL_SEXP *
gb_save(XLISP_ENV * env,XL_SEXP * s)
{
XL_SEXP * ss, * ss1;
int mode,p;
int type;
STREAM * st;
L_CHAR * filename;
int inv_arg;
CODE_METHOD * cm;
	cm = std_cm;
	ss = eval(env,get_el(s,1));
	switch ( get_type(ss) ) {
	case XLT_ERROR:
		return ss;
	case XLT_STRING:
		filename = ss->string.data;
		break;
	default:
		inv_arg = 1;
		goto typemissmatch;
	}
	ss = eval(env,get_el(s,2));
	switch ( get_type(ss) ) {
	case XLT_ERROR:
		return ss;
	case XLT_INTEGER:
		mode = ss->integer.data;
		break;
	default:
		inv_arg = 2;
		goto typemissmatch;
	}
	ss = eval(env,get_el(s,3));
	switch ( get_type(ss) ) {
	case XLT_ERROR:
		return ss;
	case XLT_INTEGER:
		p = ss->integer.data;
		break;
	default:
		inv_arg = 3;
		goto typemissmatch;
	}
	ss = eval(env,get_el(s,4));
	switch ( get_type(ss) ) {
	case XLT_ERROR:
		return ss;
	case XLT_STRING:
		if ( l_strcmp(ss->string.data,
				l_string(std_cm,"raw")) == 0 )
			type = 0;
		else if ( l_strcmp(ss->string.data,
				l_string(std_cm,"gblisp")) == 0 )
			type = 1;
		else	goto inv_param;
		break;
	default:
		inv_arg = 4;
		goto typemissmatch;
	}
	st = s_open_file(n_string(std_cm,filename),mode|O_RDWR,p);
	if ( st == 0 )
		goto access_error;
	switch ( type ) {
	case 0:
		ss = eval(env,get_el(s,5));
		switch ( get_type(ss) ) {
		case XLT_ERROR:
			s_close(st);
			return ss;
		case XLT_PAIR:
			break;
		default:
			s_close(st);
			inv_arg = 5;
			goto typemissmatch;
		}
		for ( ; get_type(ss) ; ss = cdr(ss) ) {
			ss1 = car(ss);
			switch ( get_type(ss1) ) {
			case XLT_ERROR:
				s_close(st);
				return ss1;
			case XLT_RAW:
				if ( gb_save_write(st,ss1) < 0 ) {
					s_close(st);
					goto access_error;
				}
				break;
			default:
				inv_arg = 6;
				goto typemissmatch;
			}
		}
		s_close(st);
		return 0;
	case 1:
		ss = eval(env,get_el(s,5));
		if ( get_type(ss) == XLT_ERROR ) {
			s_close(st);
			return ss;
		}
		print_sexp(st,ss,PF_MULTI_ROOT|PF_LISP);
		s_close(st);
		return 0;
	default:
		er_panic("gb_save(1)");
	}
access_error:
	return get_error(
		s->h.file,
		s->h.line,
		XLE_PROTO_OPEN_FILE,
		l_string(std_cm,"save"),
		list(	n_get_string("cannot access the file"),
			get_string(filename),
			0));
inv_param:
	return get_error(
		s->h.file,
		s->h.line,
		XLE_PROTO_INV_PARAM,
		l_string(std_cm,"save"),
		list(	n_get_string("invalid parameter"),
			0));
typemissmatch:
	return get_error(
		s->h.file,
		s->h.line,
		XLE_SEMANTICS_TYPE_MISSMATCH,
		l_string(std_cm,"save"),
		list(	n_get_string("save:type missmatch"),
			get_integer(inv_arg,0),
			0));
}

