/*
 *  Read SPSS files saved by SAVE and EXPORT commands
 *
 *  Copyright 2000-2000 Saikat DebRoy <saikat@stat.wisc.edu>
 *                      Thomas Lumley <tlumley@u.washington.edu>
 *  Copyright 2005-2014 R Core Development Team
 *  This program is free software; you can redistribute it and/or modify
 *  it under the terms of the GNU General Public License as published by
 *  the Free Software Foundation; either version 2 of the License, or
 *  (at your option) any later version.
 *
 *  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.  See the GNU General Public License for more
 *  details.
 *
 *  You should have received a copy of the GNU General Public License
 *  along with this program; if not, a copy is available at
 *  http://www.r-project.org/Licenses/
 */

#include <string.h>
#include "foreign.h"
#include "file-handle.h"
#include "pfm.h"
#include "sfm.h"
#include "avl.h"
#include "var.h"

#if !PSPP && !__GCC__
#define inline
#endif

/* Divides nonnegative X by positive Y, rounding up. */
#define DIV_RND_UP(X, Y)			\
	(((X) + ((Y) - 1)) / (Y))

char *
xstrdup(const char *s)
{
    int len = (int) strlen(s);
    char *c = R_Calloc(len + 1, char);
    strcpy(c, s);
    return c;
}

/* Returns a newly created empty dictionary. */
struct dictionary *
new_dictionary (int copy)
{
  struct dictionary *d = R_Calloc (1, struct dictionary);

  d->var = NULL;
  d->var_by_name = R_avl_create (cmp_variable, NULL);
  d->nvar = 0;

  d->N = 0;

  d->nval = 0;

  d->n_splits = 0;
  d->splits = NULL;

  d->label = NULL;

  d->n_documents = 0;
  d->documents = NULL;

  d->weight_index = -1;
  d->weight_var[0] = 0;

  d->filter_var[0] = 0;

  return d;
}

/* Find and return the variable in dictionary D having name NAME, or
   NULL if no such variable exists in D. */
struct variable *
find_dict_variable (const struct dictionary *d, const char *name)
{
  return R_avl_find (d->var_by_name, (struct variable *) name);
}

/* Initialize fields in variable V inside dictionary D with name NAME,
   type TYPE, and width WIDTH.  Initializes some other fields too. */
static inline void
common_init_stuff (struct dictionary *dict, struct variable *v,
		   const char *name, int type, int width)
{
  if (v->name != name)
    /* Avoid problems with overlap. */
    strcpy (v->name, name);

  R_avl_insert (dict->var_by_name, v);

  v->type = type;
  v->left = name[0] == '#';
  v->width = type == NUMERIC ? 0 : width;
  v->miss_type = MISSING_NONE;
  if (v->type == NUMERIC)
    {
      v->print.type = FMT_F;
      v->print.w = 8;
      v->print.d = 2;
    }
  else
    {
      v->print.type = FMT_A;
      v->print.w = v->width;
      v->print.d = 0;
    }
  v->write = v->print;
}

/* Initialize (for the first time) a variable V in dictionary DICT
   with name NAME, type TYPE, and width WIDTH.  */
void
init_variable (struct dictionary *dict, struct variable *v, const char *name,
	       int type, int width)
{
  common_init_stuff (dict, v, name, type, width);
  v->nv = type == NUMERIC ? 1 : DIV_RND_UP (width, 8);
  v->fv = dict->nval;
  dict->nval += v->nv;
  v->label = NULL;
  v->val_lab = NULL;
  v->get.fv = -1;
}

/* Creates a variable named NAME in dictionary DICT having type TYPE
   (ALPHA or NUMERIC) and, if type==ALPHA, width WIDTH.  Returns a
   pointer to the newly created variable if successful.  On failure
   (which indicates that a variable having the specified name already
   exists), returns NULL.  */
struct variable *
create_variable (struct dictionary *dict, const char *name,
		 int type, int width)
{
  if (find_dict_variable (dict, name))
    return NULL;

  {
    struct variable *new_var;

    dict->var = R_Realloc (dict->var, dict->nvar + 1, struct variable *);
    new_var = dict->var[dict->nvar] = R_Calloc (1, struct variable);

    new_var->index = dict->nvar;
    dict->nvar++;

    init_variable (dict, new_var, name, type, width);

    return new_var;
  }
}

/* Compares two value labels and returns a strcmp()-type result. */
int
val_lab_cmp (const void *a, const void *b, void *param)
{
  int width = *((int *)param);
  if (width)
    return strncmp ((char *)((struct value_label *) a)->v.s,
		    (char *)((struct value_label *) b)->v.s,
		    width);
  else
    {
      double temp = (((struct value_label *) a)->v.f
		     - ((struct value_label *) b)->v.f);
      if (temp > 0)
	return 1;
      else if (temp < 0)
	return -1;
      else
	return 0;
    }
}

/* returns an array of pointers to the data elements of an avl_tree */
/* Ugly, but the alternatives seem to be worse */

void *avlFlatten(const avl_tree *tree){
  int n;
  void **ans;


  /* T1. */
  const avl_node *an[AVL_MAX_HEIGHT];	/* Stack A: nodes. */
  const avl_node **ap = an;		/* Stack A: stack pointer. */
  const avl_node *p = tree->root.link[0];

  n=R_avl_count(tree);
  ans=R_Calloc(n, void * );

  for (;;)  /* from avl.c:avl_walk */
    {
      /* T2. */
      while (p != NULL)
	{
	  /* T3. */
	  *ap++ = p;
	  p = p->link[0];
	}

      /* T4. */
      if (ap == an)
	  return ans;
      p = *--ap;

      /* T5. */
      n--;
      ans[n]=p->data;
      p = p->link[1];
    }

}


static SEXP getSPSSvaluelabels(struct dictionary *dict)
{
    SEXP ans, somelabels, somevalues;
    int nlabels, nvars, i, j;
    struct value_label **flattened_labels;
    struct avl_tree *labelset;
    unsigned char tmp[MAX_SHORT_STRING+1];

    nvars = dict->nvar;
    if (nvars == 0) return R_NilValue;
    PROTECT(ans = allocVector(VECSXP, nvars));

    for(i = 0; i < nvars; i++) {
	labelset = (dict->var)[i]->val_lab;
	if (!labelset) continue;
	nlabels = R_avl_count(labelset);
	flattened_labels = avlFlatten(labelset);
	PROTECT(somelabels = allocVector(STRSXP, nlabels));
	if ((dict->var)[i]->type == NUMERIC) {
	    double *rx;
	    PROTECT(somevalues = allocVector(REALSXP, nlabels));
	    rx = REAL(somevalues);
	    for(j = 0; j < nlabels; j++) {
		SET_STRING_ELT(somelabels, j, mkChar(flattened_labels[j]->s));
		rx[j] = flattened_labels[j]->v.f;
	    }
	} else {
	    PROTECT(somevalues = allocVector(STRSXP, nlabels));
	    for(j = 0; j < nlabels; j++) {
		SET_STRING_ELT(somelabels, j, mkChar(flattened_labels[j]->s));
		memcpy(tmp,flattened_labels[j]->v.s, MAX_SHORT_STRING);
		tmp[MAX_SHORT_STRING] = '\0';
		SET_STRING_ELT(somevalues, j, mkChar((char *)tmp));
	    }
	}
	R_Free(flattened_labels);
	namesgets(somevalues, somelabels);
	SET_VECTOR_ELT(ans, i, somevalues);
	UNPROTECT(2); /*somevalues, somelabels*/
    }
    UNPROTECT(1);
    return ans;
}

static SEXP getSPSSmissing(struct dictionary *dict, int *have_miss)
{
    SEXP ans, elt, nm, value;
    int nvars, i;

    nvars = dict->nvar;
    if (nvars == 0) return R_NilValue;
    PROTECT(ans = allocVector(VECSXP, nvars));

    for(i = 0; i < nvars; i++) {
	struct variable *v = dict->var[i];
	int j, n = 0;
	const char *type="unknown";
	switch (v->miss_type) {
	case MISSING_NONE:
	    type = "none";
	    break;
	case MISSING_1:
	    n = 1;
	    type = "one";
	    break;
	case MISSING_2:
	    n = 2;
	    type = "two";
	    break;
	case MISSING_3:
	    n = 3;
	    type = "three";
	    break;
	case MISSING_RANGE:
	    n = 2;
	    type = "range";
	    break;
	case MISSING_LOW:
	    n = 1;
	    type = "low";
	    break;
	case MISSING_HIGH:
	    n = 1;
	    type = "high";
	    break;
	case MISSING_RANGE_1:
	    n = 3;
	    type = "range+1";
	    break;
	case MISSING_LOW_1:
	    n = 2;
	    type = "low+1";
	    break;
	case MISSING_HIGH_1:
	    n = 2;
	    type = "high+1";
	    break;
	default:
	    type = "unknown";
	}
	if (strcmp(type, "none")) (*have_miss)++;
	if (n > 0) {
	    elt = allocVector(VECSXP, 2);
	    SET_VECTOR_ELT(ans, i, elt);
	    PROTECT(nm = allocVector(STRSXP, 2));
	    SET_STRING_ELT(nm, 0, mkChar("type"));
	    SET_STRING_ELT(nm, 1, mkChar("value"));
	    setAttrib(elt, R_NamesSymbol, nm);
	    SET_VECTOR_ELT(elt, 0, mkString(type));
	    if (v->type == NUMERIC) {
		double *rx;
		PROTECT(value = allocVector(REALSXP, n));
		rx = REAL(value);
		for(j = 0; j < n; j++) rx[j] = v->missing[j].f;
	    } else {
		PROTECT(value = allocVector(STRSXP, n));
		for(j = 0; j < n; j++)
		    SET_STRING_ELT(value, j, 
				   mkChar((const char *)v->missing[j].s));
	    }
	    SET_VECTOR_ELT(elt, 1, value);	
	    UNPROTECT(2);
	} else {
	    elt = allocVector(VECSXP, 1);
	    SET_VECTOR_ELT(ans, i, elt);
	    setAttrib(elt, R_NamesSymbol, mkString("type"));
	    SET_VECTOR_ELT(elt, 0, mkString(type));
	}
    }
    UNPROTECT(1); 
    return ans;
}

static SEXP
read_SPSS_PORT(const char *filename)
{
    struct file_handle *fh = fh_get_handle_by_filename(filename);
    struct pfm_read_info inf;
    struct dictionary *dict = pfm_read_dictionary(fh, &inf);
    SEXP ans = PROTECT(allocVector(VECSXP, dict->nvar));
    SEXP ans_names = PROTECT(allocVector(STRSXP, dict->nvar));
    union value *case_vals;
    int i;
    int ncases = 0;
    int N = 10;
    int nval = 0;
    int nvar_label;
    SEXP val_labels;
    SEXP variable_labels;
    SEXP miss_labels; int have_miss = 0;

    /* Set the fv and lv elements of all variables in the
       dictionary. */
    for (i = 0; i < dict->nvar; i++) {
	struct variable *v = dict->var[i];

	v->fv = nval;
	nval += v->nv;
    }
    dict->nval = nval;
    if (!nval)
	error(_("nval is 0"));
    case_vals = (union value *) R_alloc(dict->nval, sizeof(union value));

    for (i = 0; i < dict->nvar; i++) {
	struct variable *v = dict->var[i];

	if (v->get.fv == -1)
	    continue;

	SET_STRING_ELT(ans_names, i, mkChar(dict->var[i]->name));
	if (v->type == NUMERIC) {
	    SET_VECTOR_ELT(ans, i, allocVector(REALSXP, N));
	} else {
	    SET_VECTOR_ELT(ans, i, allocVector(STRSXP, N));
	    case_vals[v->fv].c =
		(unsigned char *) R_alloc(v->width + 1, 1);
	    ((char *) &case_vals[v->fv].c[0])[v->width] = '\0';
	}
    }

    while(pfm_read_case(fh, case_vals, dict)) {
	if (ncases == N) {
	    N *= 2;
	    for (i = 0; i < dict->nvar; i++) {
		SEXP elt = VECTOR_ELT(ans, i);
		elt = lengthgets(elt, N);
		SET_VECTOR_ELT(ans, i, elt);
	    }
	}
	for (i = 0; i < dict->nvar; i++) {
	    struct variable *v = dict->var[i];

	    if (v->get.fv == -1)
		continue;

	    if (v->type == NUMERIC) {
		REAL(VECTOR_ELT(ans, i))[ncases] = case_vals[v->fv].f;
	    } else {
		SET_STRING_ELT(VECTOR_ELT(ans, i), ncases,
			       mkChar((char *)case_vals[v->fv].c));
	    }
	}
	++ncases;
    }
    if (N != ncases) {
	for (i = 0; i < dict->nvar; i++) {
	    SEXP elt = VECTOR_ELT(ans, i);
	    elt = lengthgets(elt, ncases);
	    SET_VECTOR_ELT(ans, i, elt);
	}
    }

    fh_close_handle(fh);

    /* get all the value labels */
    PROTECT(val_labels = getSPSSvaluelabels(dict));
    namesgets(val_labels, ans_names);
    setAttrib(ans, install("label.table"), val_labels);
    UNPROTECT(1);

    /* get SPSS variable labels */
    PROTECT(variable_labels = allocVector(STRSXP, dict->nvar));
    nvar_label = 0;
    for (i = 0; i < dict->nvar; i++) {
	char *lab = dict->var[i]->label;
	if (lab != NULL) {
	    nvar_label++;
	    SET_STRING_ELT(variable_labels, i, mkChar(lab));
	}
    }
    if (nvar_label > 0) {
	namesgets(variable_labels, ans_names);
	setAttrib(ans, install("variable.labels"), variable_labels);
    }
    UNPROTECT(1);

    /* report missingness */
    PROTECT(miss_labels = getSPSSmissing(dict, &have_miss));
    if(have_miss) {
	namesgets(miss_labels, duplicate(ans_names));
	setAttrib(ans, install("missings"), miss_labels);
    }
    UNPROTECT(1);
   
    free_dictionary(dict);
    setAttrib(ans, R_NamesSymbol, ans_names);
    UNPROTECT(2);
    return ans;
}

static SEXP
read_SPSS_SAVE(const char *filename)
{
    struct file_handle *fh = fh_get_handle_by_filename(filename);
    struct sfm_read_info inf;
    struct dictionary *dict;
    SEXP ans;
    SEXP ans_names;
    union value *case_vals;
    int i;
    int nvar_label;
    int nval = 0;
    SEXP val_labels;
    SEXP variable_labels;
    SEXP miss_labels; int have_miss = 0;

    /* package multcomp has an example in which this does not get
       initialized */
    inf.encoding = 0;
    dict = sfm_read_dictionary(fh, &inf);
    ans = PROTECT(allocVector(VECSXP, dict->nvar));
    ans_names = PROTECT(allocVector(STRSXP, dict->nvar));
    /* Set the fv and lv elements of all variables in the
       dictionary. */
    for (i = 0; i < dict->nvar; i++) {
	struct variable *v = dict->var[i];

	v->fv = nval;
	nval += v->nv;
    }
    dict->nval = nval;
    if (!nval)
	error(_("nval is 0"));
    case_vals = (union value *) R_alloc(dict->nval, sizeof(union value));

    for (i = 0; i < dict->nvar; i++) {
	struct variable *v = dict->var[i];

	if (v->get.fv == -1)
	    continue;

	SET_STRING_ELT(ans_names, i, mkChar(dict->var[i]->name));
	if (v->type == NUMERIC) {
	    SET_VECTOR_ELT(ans, i, allocVector(REALSXP, inf.ncases));
	} else {
	    SET_VECTOR_ELT(ans, i, allocVector(STRSXP, inf.ncases));
	    case_vals[v->fv].c =
		(unsigned char *) R_alloc(v->width + 1, 1);
	    ((char *) &case_vals[v->fv].c[0])[v->width] = '\0';
	}
    }
    for (i = 0; i < inf.ncases; i++) {
	int j;
	sfm_read_case(fh, case_vals, dict);  // should check return value
	for (j = 0; j < dict->nvar; j++) {
	    struct variable *v = dict->var[j];

	    if (v->get.fv == -1)
		continue;

	    if (v->type == NUMERIC) {
		REAL(VECTOR_ELT(ans, j))[i] = case_vals[v->fv].f;
	    } else {
		SET_STRING_ELT(VECTOR_ELT(ans, j), i,
			       mkChar((char *)case_vals[v->fv].c));
	    }
	}
    }
    sfm_maybe_close(fh);

    /* get all the value labels */
    PROTECT(val_labels = getSPSSvaluelabels(dict));
    namesgets(val_labels, duplicate(ans_names));
    setAttrib(ans, install("label.table"), val_labels);
    UNPROTECT(1);

    /* get SPSS variable labels */
    PROTECT(variable_labels = allocVector(STRSXP, dict->nvar));
    nvar_label = 0;
    for (i = 0; i < dict->nvar; i++) {
	char *lab = dict->var[i]->label;
	if (lab != NULL) {
	    nvar_label++;
	    SET_STRING_ELT(variable_labels, i, mkChar(lab));
	}
    }
    if (nvar_label > 0) {
	namesgets(variable_labels, ans_names);
	setAttrib(ans,install("variable.labels"), variable_labels);
    }
    UNPROTECT(1);

    /* report missingness */
    PROTECT(miss_labels = getSPSSmissing(dict, &have_miss));
    if(have_miss) {
	namesgets(miss_labels, duplicate(ans_names));
	setAttrib(ans, install("missings"), miss_labels);
    }
    UNPROTECT(1);

    SEXP cpsym = install("codepage");
    free_dictionary(dict);
    setAttrib(ans, R_NamesSymbol, ans_names);
    setAttrib(ans, cpsym, ScalarInteger(inf.encoding));
    UNPROTECT(2);
    return ans;
}

extern int R_fgetc(FILE *stream);

static size_t
fread_pfm(void *ptr, size_t size, size_t nobj, FILE *stream)
{
    size_t nbytes = size * nobj;
    size_t i;
    char *c_ptr = ptr;

    for (i = 0; i < nbytes; i++) {
	int c = fgetc(stream);
	if (c == '\r') {
	    c = fgetc(stream);
	    if ( c != '\n') {
		ungetc(c, stream);
		c = '\r';
	    }
	}
	if (c == '\n')
	    fgetc(stream);
	if (c == EOF)
	    break;
	*c_ptr++ = (char) c;
    }
    if (i % size != 0) {
	i -= i % size;
    }
    return i/size;
}

static int
is_PORT(FILE *fp)
{
    /* For now at least, just ignore the vanity splash strings. */
    int trans_temp[256];

    if (196 != fread_pfm(trans_temp, sizeof(char), 196, fp))
	return 0;
    {
	unsigned char src[256];
	int i;

	if (256 != fread_pfm(src, sizeof(char), 256, fp))
	    return 0;
	for (i = 0; i < 256; i++)
	    trans_temp[i] = -1;

	/* 0 is used to mark untranslatable characters, so we have to mark
	   it specially. */
	trans_temp[src[64]] = 64;
	for (i = 0; i < 256; i++) {
	    if (trans_temp[src[i]] == -1)
		trans_temp[src[i]] = i;
	}

	for (i = 0; i < 256; i++) {
	    if (trans_temp[i] == -1)
		trans_temp[i] = 0;
	}

    }

    {
	unsigned char sig[9] = {92, 89, 92, 92, 89, 88, 91, 93, '\0'};
	unsigned char buf[9];
	int i;

	buf[8] = '\0';
	if (8 != fread_pfm(buf, sizeof(char), 8, fp))
	    return 0;
	for (i = 0; i < 8; i++) {
	    if (sig[i] != trans_temp[buf[i]])
		return 0;
	}
    }
    return 1;
}

#include <string.h>
#include <errno.h>

SEXP
do_read_SPSS(SEXP file)
{
    const char *filename = CHAR(PROTECT(asChar(file)));
    FILE *fp = fopen(R_ExpandFileName(filename), "rb");
    char buf[5];
    SEXP ans;

    if(!fp)
	error(_("unable to open file: '%s'"), strerror(errno));
    if(fread_pfm(buf, sizeof(char), 4, fp) != 4) {
	fclose(fp);
	error(_("problem in reading file '%s'"), filename);
    }
    buf[4] = '\0';

    if (0 == strncmp("$FL2", buf, 4)) {
	fclose(fp);
	ans = read_SPSS_SAVE(filename);
    } else {
	if (!is_PORT(fp)) {
	    fclose(fp);
	    error(_("file '%s' is not in any supported SPSS format"),
		  filename);
	}
	fclose(fp);
	ans = read_SPSS_PORT(filename);
    }
    UNPROTECT(1);
    return ans;
}

void
spss_init(void)
{
    fh_init_files();
}