/* libsizzle/regexp.c - regular expression functions
 
  Copyright (C) 1999, 2000 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
 
  This 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, or (at your option)
  any later version.
  
  This software 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 package; see the file COPYING.  If not, write to
  the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  Boston, MA 02111-1307, USA.  */

#if HAVE_CONFIG_H
# include <config.h>
#endif 

#if ENABLE_REGEXP && HAVE_REGCOMP

#include <assert.h>
#include <stdlib.h>
#include <regex.h>

#if ENABLE_NLS
# include <libintl.h>
# define _(String) gettext(String)
#else
# define _(String) (String)
#endif

#include "alloc.h"
#include "node.h"
#include "validate.h"
#include "port.h"
#include "vector.h"
#include "capi.h"
#include "regexp.h"

/* This is defined by some regex libraries and omitted by others (thx
   to the Guile ppl for this one).  */
#ifndef REG_BASIC
#define REG_BASIC 0
#endif

zzz_object_t zzz_tagged_type_regexp;

/*:doc
  regexp?
  (regexp? obj) => boolean
  Returns @code{#t} if @var{obj} is a compiled regular expression object,
  @code{#f} otherwise.
  doc:*/
#define FUNC_NAME "regexp?"
static result_t
regexp_p_func (zzz_scm_t env, zzz_scm_t obj, zzz_scm_t * result)
{
  if (regexp_p (obj))
    *result = zzz_true_value;
  else
    *result = zzz_false_value;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  make-regexp
  (make-regexp flags ...) => regex
  Create a compiled regular expression object which represents the
  string @var{string}.  The following additional arguments can be
  passed to control regular expression compilation: regexp/icase
  regexp/extended regexp/basic regexp/newline
  doc:*/
#define FUNC_NAME "make-regexp"
static result_t
make_regexp_func (zzz_scm_t env, zzz_scm_t string, zzz_scm_t flags,
		  zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  zzz_scm_t res;
  int arg_num = 2;
  int cflags = REG_EXTENDED;

  CHECK_TYPE (1, string_p (string), zzz_string_type_name);
  while (cons_p (flags))
    {
      CHECK_TYPE (arg_num, integer_p (car (flags)), zzz_integer_type_name);
      if (integer_val (car (flags)) == REG_BASIC)
	cflags &= ~REG_EXTENDED;
      else
	cflags |= integer_val (car (flags));
      flags = cdr (flags);
      arg_num++;
    }
  cflags &= ~REG_NOSUB;
  res = zzz_make_regexp (string_val (string), string_len (string), cflags);
  if (!regexp_valid (res))
    {
      *result = zzz_make_misc_error_exception
	(zzz_make_list
	 (zzz_make_string (_("regexp error: "), -1),
	  regexp_string (res),
	  NULL));
      return RESULT_EXCEPTION;
    }
  *result = res;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  regexp-exec
  (regexp-exec rx str) => #f | vector
  Match the regular expression @var{rx} against @var{string}.  If
  @var{start} is given, start matching at that position.  Flags may be
  a mask of the following constants: regexp/notbol regexp/noteol
  doc:*/
#define FUNC_NAME "regexp-exec"
static result_t
regexp_exec_func (zzz_scm_t env, zzz_scm_t regex, zzz_scm_t str, 
		  zzz_scm_t start, zzz_scm_t flags, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  zzz_scm_t tmp;
  int res;
  char buf[256];

  /* FIXME: Remove this limit. */
  int nmatch = 64;
  regmatch_t match[64];
  int idx, cnt;

  CHECK_TYPE (1, regexp_p (regex), zzz_regexp_type_name);
  CHECK_TYPE (2, string_p (str), zzz_string_type_name);
  if (start != zzz_undefined)
    {
      CHECK_TYPE (3, integer_p (start), zzz_integer_type_name);
      if (flags != zzz_undefined)
	CHECK_TYPE (4, integer_p (flags), zzz_integer_type_name);
      else
	flags = zzz_make_integer (0);
    }
  else
    {
      start = zzz_make_integer (0);
      flags = zzz_make_integer (0);
    }
  if (integer_val (start) > (int) string_len (str))
    {
      *result = zzz_make_misc_error_exception
	(zzz_make_list
	 (zzz_make_string
	  (_("start index greater than string length in call to `"), -1),
	  zzz_make_string (s_func_name, -1), 
	  zzz_make_string ("'", -1), 
	  NULL));
      return RESULT_EXCEPTION;
    }
  res = regexec (&regexp_regex (regex), string_val (str) + integer_val (start),
		 nmatch, match, integer_val (flags));
  if (!res)
    {
      for (cnt = 0; cnt < nmatch; cnt++)
	if (match[cnt].rm_so < 0)
	  break;
      tmp = zzz_make_vector (cnt + 1);
      for (idx = 0; idx < cnt; idx++)
	zzz_vector_put (tmp, idx + 1,
			zzz_cons (zzz_make_integer (match[idx].rm_so +
						    integer_val (start)),
				  zzz_make_integer (match[idx].rm_eo +
						    integer_val (start))));
      zzz_vector_put (tmp, 0,
		      zzz_make_ro_string (string_val (str), string_len (str)));
      *result = tmp;
    }
  else if (res == REG_NOMATCH)
    {
      *result = zzz_false_value;
    }
  else
    {
      res = regerror (res, &regexp_regex (regex), buf, sizeof (buf));
      *result = zzz_make_misc_error_exception
	(zzz_make_list
	 (zzz_make_string (_("regexp error: "), -1),
	  zzz_make_ro_string (buf, res), 
	  NULL));
      return RESULT_EXCEPTION;
    }
  return RESULT_SUCCESS;
}
#undef FUNC_NAME



static void *
regexp_constructor (zzz_tagged_t tagged, void * data0,
		    void * data1, void * data2)
{
  char * str = data0;
  int len = (long) data1;
  int flags = (long) data2;
  regexp_desc_t desc;
  char buf[256];
  int res;

  desc = zzz_malloc (sizeof (struct regexp_descriptor));
  desc->valid = 0;
  res = regcomp (&desc->regex, str, flags);
  if (!res)
    {
      desc->valid = 1;
      desc->string = zzz_make_ro_string (str, len);
    }
  else
    {
      res = regerror (res, &desc->regex, buf, sizeof (buf));
      desc->string = zzz_make_ro_string (buf, res);
    }
  tagged->fill[1] = (zzz_object_t) desc;
  return tagged;
}

static void
regexp_print (zzz_scm_t port, zzz_tagged_t tagged, zzz_print_state_t state)
{
  zzz_scm_t result;
  regexp_desc_t desc = tagged_data0 (tagged);
  zzz_port_puts (port, "#<regexp:", 9, &result);
  zzz_port_print (port, desc->string, state, &result);
  zzz_port_puts (port, ">", 1, &result);
}

static void
regexp_free (zzz_tagged_t tagged)
{
  regexp_desc_t desc = tagged_data0 (tagged);
  if (desc->valid)
    regfree (&desc->regex);
  zzz_free (desc, sizeof (struct regexp_descriptor));
}

static void
regexp_mark (zzz_tagged_t tagged)
{
  regexp_desc_t desc = tagged_data0 (tagged);
  zzz_mark_cell (desc->string);
}

zzz_scm_t
zzz_make_regexp (char * str, int len, int flags)
{
  return zzz_create_tagged_cell (zzz_tagged_type_regexp, str,
				 (void *) ((long) len),
				 (void *) ((long) flags));
}

result_t
zzz_init_regexp (void)
{
  /* Define the tagged type for compiled regular expressions.  */
  zzz_tagged_type_regexp = zzz_define_tagged_type (regexp_constructor,
						   regexp_print,
						   regexp_free,
						   regexp_mark,
						   NULL);

  /* Define some constants to be used in the regular expression
     creation and matching primitives.  */
  /*:doc
    regexp/extended
    Constant
    Support extended Posix regular expressions (this is the default).
    doc:*/
  zzz_define_constant ("regexp/extended", zzz_make_integer (REG_EXTENDED));
  /*:doc
    regexp/icase
    Constant
    The matching is performed case-insensitively.
    doc:*/
  zzz_define_constant ("regexp/icase", zzz_make_integer (REG_ICASE));
  /*:doc
    regexp/basic
    Constant
    Do not support extended Posix regular expressions.
    doc:*/
  zzz_define_constant ("regexp/basic", zzz_make_integer (REG_BASIC));
  /*:doc
    regexp/newline
    Constant
    Treat a newline in the matched string as beginning/end of the string as
    far as the beginning-of-line and end-of-line operators are concerned.
    doc:*/
  zzz_define_constant ("regexp/newline", zzz_make_integer (REG_NEWLINE));

  /*:doc
    regexp/notbol
    Constant
    The match-beginning-of-line operator always fails to match.
    doc:*/
  zzz_define_constant ("regexp/notbol", zzz_make_integer (REG_NOTBOL));
  /*:doc
    regexp/noteol
    The end-beginning-of-line operator always fails to match.
    doc:*/
  zzz_define_constant ("regexp/noteol", zzz_make_integer (REG_NOTEOL));

  zzz_define_function ("regexp?", (zzz_prim_t) regexp_p_func, argv_1_0_0);
  zzz_define_function ("make-regexp", (zzz_prim_t) make_regexp_func,
		       argv_1_0_1);
  zzz_define_function ("regexp-exec", (zzz_prim_t) regexp_exec_func,
		       argv_2_2_0);

  return RESULT_SUCCESS;
}

int zzz_config_have_regexp = 1;

#else  /* !(ENABLE_REGEXP && HAVE_REGCOMP)*/

int zzz_config_have_regexp = 0;

#endif /* !(ENABLE_REGEXP && HAVE_REGCOMP)*/
