yap-6.3/os/pl-locale.c

/*  Part of SWI-Prolog

    Author:        Jan Wielemaker
    E-mail:        J.Wielemaker@vu.nl
    WWW:           http://www.swi-prolog.org
    Copyright (C): 2013, VU University Amsterdam

    This library is free software; you can redistribute it and/or
    modify it under the terms of the GNU Lesser General Public
    License as published by the Free Software Foundation; either
    version 2.1 of the License, or (at your option) any later version.

    This library 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
    Lesser General Public License for more details.

    You should have received a copy of the GNU Lesser General Public
    License along with this library; if not, write to the Free Software
    Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA
*/

#include "pl-incl.h"
#include "pl-locale.h"

#if defined(__sun) || __ENVIRONMENT_MAC_OS_X_VERSION_MIN_REQUIRED__ < 1070
#undef HAVE_WCSDUP			/* No prototype, so better use our own */
#endif

#ifdef O_LOCALE

#include <locale.h>

#define LOCK()   PL_LOCK(L_LOCALE)	/* MT locking */
#define UNLOCK() PL_UNLOCK(L_LOCALE)

#undef LD				/* fetch LD once per function */
#define LD LOCAL_LD

#define LSTR_MAX 16

#ifndef HAVE_LOCALECONV
typedef struct
{ char *decimal_point;
  char *thousands_sep;
  char *grouping;
} lconv;

struct lconv *
localeconv(void)
{ static struct lconv defl =
  { ".",
    ",",
    "\003\003"
  };

  return &defl;
}
#endif


#ifndef HAVE_WCSDUP
static wchar_t *
my_wcsdup(const wchar_t *in)
{ wchar_t *copy = malloc((wcslen(in)+1)*sizeof(wchar_t));

  if ( copy )
    return wcscpy(copy, in);

  return NULL;
}
#define wcsdup(ws) my_wcsdup(ws)
#endif


static wchar_t *
ls_to_wcs(const char *in, const wchar_t *on_error)
{ wchar_t buf[LSTR_MAX];
  mbstate_t state;

  memset(&state, 0, sizeof(state));
  mbsrtowcs(buf, &in, LSTR_MAX, &state);
  if ( in == NULL )
  { return wcsdup(buf);
  } else
  { Sdprintf("Illegal locale string: %s\n", in);
    return wcsdup(on_error);
  }
}


static int
init_locale_strings(PL_locale *l, struct lconv *conv)
{ if ( conv )
  { l->decimal_point = ls_to_wcs(conv->decimal_point, L".");
    l->thousands_sep = ls_to_wcs(conv->thousands_sep, L",");
    l->grouping      = strdup(conv->grouping);

    return TRUE;
  } else
  { l->decimal_point = wcsdup(L".");
    l->thousands_sep = wcsdup(L",");
    l->grouping      = strdup("\003");

    return FALSE;
  }
}


static PL_locale *
new_locale(PL_locale *proto)
{ PL_locale *new = PL_malloc(sizeof(*new));

  if ( new )
  { memset(new, 0, sizeof(*new));
    new->magic = LOCALE_MAGIC;

    if ( proto )
    { new->decimal_point = wcsdup(proto->decimal_point);
      new->thousands_sep = wcsdup(proto->thousands_sep);
      new->grouping      = strdup(proto->grouping);
    } else
    { init_locale_strings(new, localeconv());
    }
  }

  return new;
}


static void
free_locale_strings(PL_locale *l)
{ free(l->decimal_point);
  free(l->thousands_sep);
  free(l->grouping);
}

static void
free_locale(PL_locale *l)
{ if ( l )
  { free_locale_strings(l);

    if ( l->alias )
      PL_unregister_atom(l->alias);

    PL_free(l);
  }
}

static void
update_locale(PL_locale *l, int category, const char *locale)
{ free_locale_strings(l);
  init_locale_strings(l, localeconv());
}


static int
alias_locale(PL_locale *l, atom_t alias)
{ int rc;

  LOCK();

  if ( !GD->locale.localeTable )
    GD->locale.localeTable = newHTable(16);

  if ( addHTable(GD->locale.localeTable, (void*)alias, l) )
  { l->alias = alias;
    PL_register_atom(alias);
    rc = TRUE;
  } else
  { GET_LD
    term_t obj = PL_new_term_ref();

    PL_put_atom(obj, alias);
    rc = PL_error("locale_create", 2, "Alias name already taken",
		  ERR_PERMISSION, ATOM_create, ATOM_locale, obj);
  }
  UNLOCK();

  return rc;
}


		 /*******************************
		 *	  LOCALE BLOB		*
		 *******************************/

typedef struct locale_ref
{ PL_locale	*data;
} locale_ref;


static int
write_locale_ref(IOSTREAM *s, atom_t aref, int flags)
{ locale_ref *ref = PL_blob_data(aref, NULL, NULL);
  (void)flags;

  Sfprintf(s, "<locale>(%p)", ref->data);

  return TRUE;
}


static void
acquire_locale_ref(atom_t aref)
{ locale_ref *ref = PL_blob_data(aref, NULL, NULL);

  (void)ref;
}


static int
release_locale_ref(atom_t aref)
{ locale_ref *ref = PL_blob_data(aref, NULL, NULL);

  LOCK();
  if ( ref->data->references == 0 )
    free_locale(ref->data);
  else
    ref->data->symbol = 0;
  UNLOCK();

  return TRUE;
}


static int
save_locale_ref(atom_t aref, IOSTREAM *fd)
{ locale_ref *ref = PL_blob_data(aref, NULL, NULL);
  (void)fd;

  return PL_warning("Cannot save reference to <locale>(%p)", ref->data);
}


static atom_t
load_locale_ref(IOSTREAM *fd)
{ (void)fd;

  return PL_new_atom("<saved-locale-ref>");
}


static PL_blob_t locale_blob =
{ PL_BLOB_MAGIC,
  PL_BLOB_UNIQUE,
  "locale",
  release_locale_ref,
  NULL,
  write_locale_ref,
  acquire_locale_ref,
  save_locale_ref,
  load_locale_ref
};


		 /*******************************
		 *	   PROLOG HANDLE	*
		 *******************************/

int
unifyLocale(term_t t, PL_locale *l, int alias)
{ GET_LD
  term_t b;

  if ( l->alias && alias )
    return PL_unify_atom(t, l->alias);

  if ( l->symbol )
    return PL_unify_atom(t, l->symbol);

  if ( (b=PL_new_term_ref()) &&
       PL_put_blob(b, &l, sizeof(l), &locale_blob) )
  { PL_get_atom(b, &l->symbol);
    assert(l->symbol);
    return PL_unify(t, b);
  }

  return FALSE;
}


int
getLocale(term_t t, PL_locale **lp)
{ GET_LD
  atom_t a;

  if ( PL_get_atom(t, &a) )
  { PL_locale *l = NULL;
    PL_blob_t *bt;
    locale_ref *ref;

    if ( a == ATOM_current_locale )
    { GET_LD

      l = LD->locale.current;
    } else if ( (ref=PL_blob_data(a, NULL, &bt)) && bt == &locale_blob )
    { l = ref->data;
    } else if ( GD->locale.localeTable )
    { Symbol s;

      if ( (s=lookupHTable(GD->locale.localeTable, (void*)a)) )
	l = s->value;
    }

    if ( l )
    { assert(l->magic == LOCALE_MAGIC);
      *lp = acquireLocale(l);
      return TRUE;
    }
  }

  return FALSE;
}


int
getLocaleEx(term_t t, PL_locale **lp)
{ GET_LD

  if ( getLocale(t, lp) )
    return TRUE;

  if ( PL_is_atom(t) )
    return PL_existence_error("locale", t);
  else
    return PL_type_error("locale", t);
}


		 /*******************************
		 *	 PROLOG BINDING		*
		 *******************************/

static int		/* locale_property(Mutex, alias(Name)) */
locale_alias_property(PL_locale *l, term_t prop ARG_LD)
{ if ( l->alias )
    return PL_unify_atom(prop, l->alias);

  return FALSE;
}

static int		/* locale_property(Locale, decimal_point(Atom)) */
locale_decimal_point_property(PL_locale *l, term_t prop ARG_LD)
{ if ( l->decimal_point && l->decimal_point[0] )
    return PL_unify_wchars(prop, PL_ATOM, (size_t)-1, l->decimal_point);

  return FALSE;
}

static int		/* locale_property(Locale, thousands_sep(Atom)) */
locale_thousands_sep_property(PL_locale *l, term_t prop ARG_LD)
{ if ( l->thousands_sep && l->thousands_sep[0] )
    return PL_unify_wchars(prop, PL_ATOM, (size_t)-1, l->thousands_sep);

  return FALSE;
}

static int		/* locale_property(Locale, grouping(List)) */
locale_grouping_property(PL_locale *l, term_t prop ARG_LD)
{ if ( l->grouping && l->grouping[0] )
  { term_t tail = PL_copy_term_ref(prop);
    term_t head = PL_new_term_ref();
    char *s;

    for(s=l->grouping; ; s++)
    { if ( !PL_unify_list(tail, head, tail) )
	return FALSE;
      if ( s[1] == 0 || (s[1] == s[0] && s[2] == 0) )
	return ( PL_unify_term(head, PL_FUNCTOR, FUNCTOR_repeat1,
			       PL_INT, (int)s[0]) &&
		 PL_unify_nil(tail)
	       );
      if ( s[0] == CHAR_MAX )
	return PL_unify_nil(tail);
      if ( !PL_unify_integer(head, s[0]) )
	return FALSE;
    }
  }

  return FALSE;
}


typedef struct
{ functor_t functor;			/* functor of property */
  int (*function)();			/* function to generate */
} lprop;

static const lprop lprop_list [] =
{ { FUNCTOR_alias1,	    locale_alias_property },
  { FUNCTOR_decimal_point1, locale_decimal_point_property },
  { FUNCTOR_thousands_sep1, locale_thousands_sep_property },
  { FUNCTOR_grouping1,      locale_grouping_property },
  { 0,			    NULL }
};

typedef struct
{ TableEnum e;				/* Enumerator on mutex-table */
  PL_locale *l;				/* current locale */
  const lprop *p;			/* Pointer in properties */
  int enum_properties;			/* Enumerate the properties */
} lprop_enum;


static int
get_prop_def(term_t t, atom_t expected, const lprop *list, const lprop **def)
{ GET_LD
  functor_t f;

  if ( PL_get_functor(t, &f) )
  { const lprop *p = list;

    for( ; p->functor; p++ )
    { if ( f == p->functor )
      { *def = p;
        return TRUE;
      }
    }

    PL_error(NULL, 0, NULL, ERR_DOMAIN, expected, t);
    return -1;
  }

  if ( PL_is_variable(t) )
    return 0;

  PL_error(NULL, 0, NULL, ERR_TYPE, expected, t);
  return -1;
}


static int
advance_lstate(lprop_enum *state)
{ if ( state->enum_properties )
  { state->p++;
    if ( state->p->functor )
      return TRUE;

    state->p = lprop_list;
  }
  if ( state->e )
  { Symbol s;

    if ( (s = advanceTableEnum(state->e)) )
    { state->l = s->value;

      return TRUE;
    }
  }

  return FALSE;
}


static void
free_lstate(lprop_enum *state)
{ if ( state->e )
    freeTableEnum(state->e);
  else if ( state->l )
    releaseLocale(state->l);

  freeForeignState(state, sizeof(*state));
}


static int
get_atom_arg(term_t t, atom_t *a)
{ GET_LD
  term_t t2 = PL_new_term_ref();

  return PL_get_arg(1, t, t2) && PL_get_atom(t2, a);
}


/** locale_property(?Locale, ?Property) is nondet.
*/

static
PRED_IMPL("locale_property", 2, locale_property, PL_FA_NONDETERMINISTIC)
{ PRED_LD
  term_t locale = A1;
  term_t property = A2;
  lprop_enum statebuf;
  lprop_enum *state;

  switch( CTX_CNTRL )
  { case FRG_FIRST_CALL:
    { memset(&statebuf, 0, sizeof(statebuf));
      state = &statebuf;

      if ( PL_is_variable(locale) )
      { switch( get_prop_def(property, ATOM_locale_property,
			     lprop_list, &state->p) )
	{ case 1:
	  { atom_t alias;

	    if ( state->p->functor == FUNCTOR_alias1 &&
		 get_atom_arg(property, &alias) )
	    { Symbol s;

	      if ( (s=lookupHTable(GD->locale.localeTable, (void*)alias)) )
		return unifyLocale(locale, s->value, FALSE);
	      else
		return FALSE;
	    }
	    state->e = newTableEnum(GD->locale.localeTable);
	    goto enumerate;
	  }
	  case 0:
	    state->e = newTableEnum(GD->locale.localeTable);
	    state->p = lprop_list;
	    state->enum_properties = TRUE;
	    goto enumerate;
	  case -1:
	    return FALSE;
	}
      } else if ( getLocale(locale, &state->l) )
      { switch( get_prop_def(property, ATOM_locale_property,
			     lprop_list, &state->p) )
	{ case 1:
	    goto enumerate;
	  case 0:
	    state->p = lprop_list;
	    state->enum_properties = TRUE;
	    goto enumerate;
	  case -1:
	    return FALSE;
	}
      } else
      { return FALSE;
      }
    }
    case FRG_REDO:
      state = CTX_PTR;
      break;
    case FRG_CUTTED:
      state = CTX_PTR;
      free_lstate(state);
      succeed;
    default:
      assert(0);
  }

enumerate:
  if ( !state->l )			/* first time, enumerating locales */
  { Symbol s;

    assert(state->e);
    if ( (s=advanceTableEnum(state->e)) )
    { state->l = s->value;
    } else
    { freeTableEnum(state->e);
      assert(state != &statebuf);
      return FALSE;
    }
  }

  { term_t arg = PL_new_term_ref();

    if ( !state->enum_properties )
      _PL_get_arg(1, property, arg);

    for(;;)
    { if ( (*state->p->function)(state->l, arg PASS_LD) )
      { if ( state->enum_properties )
	{ if ( !PL_unify_term(property,
			      PL_FUNCTOR, state->p->functor,
			        PL_TERM, arg) )
	    goto error;
	}
	if ( state->e )
	{ if ( !unifyLocale(locale, state->l, TRUE) )
	    goto error;
	}

	if ( advance_lstate(state) )
	{ if ( state == &statebuf )
	  { lprop_enum *copy = allocForeignState(sizeof(*copy));

	    *copy = *state;
	    state = copy;
	  }

	  ForeignRedoPtr(state);
	}

	if ( state != &statebuf )
	  free_lstate(state);
	return TRUE;
      }

      if ( !advance_lstate(state) )
      { error:
	if ( state != &statebuf )
	  free_lstate(state);
	return FALSE;
      }
    }
  }
}


static int
set_chars(term_t t, wchar_t **valp)
{ wchar_t *s;

  if ( PL_get_wchars(t, NULL, &s, CVT_ATOM|CVT_EXCEPTION) )
  { free(*valp);
    if ( (*valp = wcsdup(s)) )
      return TRUE;
    return PL_no_memory();
  }

  return FALSE;
}


#define MAX_GROUPING 10

static int
get_group_size_ex(term_t t, int *s)
{ int i;

  if ( PL_get_integer_ex(t, &i) )
  { if ( i > 0 && i < CHAR_MAX )
    { *s = i;
      return TRUE;
    }
    return PL_domain_error("digit_group_size", t);
  }

  return FALSE;
}


static int
set_grouping(term_t t, char **valp)
{ GET_LD
  char s[MAX_GROUPING];
  term_t tail = PL_copy_term_ref(t);
  term_t head = PL_new_term_ref();
  char *o = s;

  while(PL_get_list_ex(tail, head, tail))
  { int g;

    if ( o-s+2 >= MAX_GROUPING )
      return PL_representation_error("digit_groups");

    if ( PL_is_functor(head, FUNCTOR_repeat1) )
    { if ( !PL_get_nil_ex(tail) )
	return FALSE;

      _PL_get_arg(1, head, head);
      if ( get_group_size_ex(head, &g) )
      { *o++ = g;
	goto end;
      }
      return FALSE;
    }
    if ( get_group_size_ex(head, &g) )
    { *o++ = g;
    } else
      return FALSE;
  }

  if ( PL_get_nil_ex(tail) )
  { *o++ = CHAR_MAX;				/* no more grouping */
  end:
    *o++ = '\0';
    free(*valp);
    if ( (*valp = strdup(s)) )
      return TRUE;
    return PL_no_memory();
  }

  return FALSE;
}


/** locale_create(-Locale, +Default, +Options) is det.
*/

static
PRED_IMPL("locale_create", 3, locale_create, 0)
{ PRED_LD
  PL_locale *def, *new;
  char *lname;

  if ( PL_get_chars(A2, &lname, CVT_LIST|CVT_STRING|REP_MB) )
  { const char *old;

    LOCK();
    if ( (old=setlocale(LC_NUMERIC, lname)) )
    { new = new_locale(NULL);
      setlocale(LC_NUMERIC, old);
    } else
    { assert(0);				/* keep compiler happy */
      return FALSE;
    }
    UNLOCK();
    if ( !old )
    { if ( errno == ENOENT )
	return PL_existence_error("locale", A2);
      else
	return PL_error(NULL, 0, MSG_ERRNO, ERR_SYSCALL, "setlocale");
    }
  } else
  { if ( !getLocaleEx(A2, &def) )
      return FALSE;
    new = new_locale(def);
    releaseLocale(def);
  }

  if ( new )
  { atom_t alias = 0;
    term_t tail = PL_copy_term_ref(A3);
    term_t head = PL_new_term_ref();
    term_t arg  = PL_new_term_ref();

    while(PL_get_list_ex(tail, head, tail))
    { atom_t pname;
      int parity;

      if ( !PL_get_name_arity(head, &pname, &parity) ||
	   parity != 1 ||
	   !PL_get_arg(1, head, arg) )
      { PL_type_error("locale_property", head);
	goto error;
      }
      if ( pname == ATOM_alias )
      { if ( !PL_get_atom_ex(arg, &alias) )
	  goto error;
      } else if ( pname == ATOM_decimal_point )
      { if ( !set_chars(arg, &new->decimal_point) )
	  goto error;
      } else if ( pname == ATOM_thousands_sep )
      { if ( !set_chars(arg, &new->thousands_sep) )
	  goto error;
      } else if ( pname == ATOM_grouping )
      { if ( !set_grouping(arg, &new->grouping) )
	  goto error;
      }
    }
    if ( !PL_get_nil_ex(tail) )
    {
    error:
      free_locale(new);
      return FALSE;
    }

    if ( alias && !alias_locale(new, alias) )
      goto error;

    return unifyLocale(A1, new, TRUE);
  } else
  { return PL_no_memory();
  }
}


static
PRED_IMPL("locale_destroy", 1, locale_destroy, 0)
{ PL_locale *l;

  if ( getLocaleEx(A1, &l) )
  { if ( l->alias )
    { Symbol s;
      atom_t alias = l->alias;

      LOCK();
      if ( (s=lookupHTable(GD->locale.localeTable, (void*)alias)) )
	deleteSymbolHTable(GD->locale.localeTable, s);
      l->alias = 0;
      PL_unregister_atom(alias);
      UNLOCK();
    }

    releaseLocale(l);
    return TRUE;
  }

  return FALSE;
}


/** set_locale(+Locale) is det.
*/

static
PRED_IMPL("set_locale", 1, set_locale, 0)
{ PRED_LD
  PL_locale *l;

  if ( getLocaleEx(A1, &l) )
  { PL_locale *ol = LD->locale.current;

    if ( l != ol )
    { IOSTREAM **sp;

      LD->locale.current = l;		/* already acquired */
      if ( ol )
	releaseLocale(ol);

      if ( (sp=_PL_streams()) )		/* set locale of standard streams */
      { int i;

	for(i=0; i<5; i++)
	  Ssetlocale(sp[i], l, NULL);
      }
    }

    return TRUE;
  }

  return FALSE;
}


/** current_locale(-Locale) is det.
*/

static
PRED_IMPL("current_locale", 1, current_locale, 0)
{ PRED_LD

  if ( LD->locale.current )
    return unifyLocale(A1, LD->locale.current, TRUE);

  return FALSE;
}



		 /*******************************
		 *	     C INTERFACE	*
		 *******************************/


static void
initDefaultsStreamsLocale(PL_locale *l)
{ IOSTREAM *s = S__getiob();
  int i;

  for(i=0; i<2; i++, s++)
  { if ( !s->locale )
      s->locale = acquireLocale(l);
  }
}


void
initLocale(void)
{ GET_LD
  PL_locale *def;

  if ( !setlocale(LC_NUMERIC, "") )
  { DEBUG(0, Sdprintf("Failed to set LC_NUMERIC locale\n"));
  }

  if ( (def = new_locale(NULL)) )
  { alias_locale(def, ATOM_default);
    def->references++;
    GD->locale.default_locale = def;
    LD->locale.current = acquireLocale(def);

    initDefaultsStreamsLocale(def);
  }
}


void
updateLocale(int category, const char *locale)
{ update_locale(GD->locale.default_locale, category, locale);
}


int
initStreamLocale(IOSTREAM *s)
{ GET_LD
  PL_locale *l;

  if ( LD )					/* a Prolog thread */
    l = LD->locale.current;
  else
    l = GD->locale.default_locale;

  if ( l )
    s->locale = acquireLocale(l);

  return TRUE;
}


PL_locale *
acquireLocale(PL_locale *l)
{ LOCK();
  l->references++;
  UNLOCK();

  return l;
}


void
releaseLocale(PL_locale *l)
{ LOCK();
  if ( --l->references == 0 && l->symbol == 0 && l->alias == 0 )
    free_locale(l);
  UNLOCK();
}




		 /*******************************
		 *      PUBLISH PREDICATES	*
		 *******************************/

BeginPredDefs(locale)
  PRED_DEF("locale_property", 2, locale_property, PL_FA_NONDETERMINISTIC)
  PRED_DEF("locale_create",   3, locale_create,   0)
  PRED_DEF("locale_destroy",  1, locale_destroy,  0)
  PRED_DEF("set_locale",      1, set_locale,      0)
  PRED_DEF("current_locale",  1, current_locale,  0)
EndPredDefs

#endif /*O_LOCALE*/