/* enables output of text_to_cname_4 logfile to track down the instable bug */
/* #define DEBUG /**/
/*
 * Copyright (c) 1995, 1996 Gunther Schadow.  All rights reserved.
 *
 * 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, write to the Free Software
 * Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 */

#ifdef _AIX
# define fid_t _protected_fid_t
# include <sys/types.h>
# undef fid_t
#endif

#include "pg_config.h"

/* Shit! I do now survive the second major change of the SWI-Prolog's API,
 * do I?! :-(
 */

#define PL_OLD_INTERFACE
#include <SWI-Prolog.h>
#ifdef PL_is_int
/* if PL_is_int is a macro, then PL_OLD_INTERFACE took effect and we
   have really the new style interface */
# define PL_NEW_INTERFACE
  typedef functor_t functor;
#endif

#include <ctype.h>
#include <string.h>
#include <v8regexp.h>
#include <stdio.h>
#include <stdlib.h>

#ifdef DEBUG
  static FILE *logfile = NULL;
#endif

/*
 * lowercase/2, uppercase/2 -- turn to lower or upper case
 *
 * lowercase(+Atom1,-Atom2).
 * uppercase(+Atom1,-Atom2).
 */

foreign_t
pl_uppercase(u, l)
term u, l;
{ char *copy;
  char *s, *q;
  atomic la;
  int thetype;

  thetype=PL_type(u);
  switch (thetype) {
  case PL_ATOM  : s = PL_atom_value(PL_atomic(u)); break;
  case PL_STRING: s = PL_string_value(PL_atomic(u)); break;
  default: return PL_warning("uppercase/2: instantiation fault in arg 1: string or atom expected");
  }

  copy = (char *) malloc(strlen(s)+1);

  for( q=copy; *s; q++, s++)
    *q = (islower(*s) ? toupper(*s) : *s);
  *q = '\0';

  switch(thetype) {
  case PL_ATOM  : la = (atomic)PL_new_atom(copy); break;
  case PL_STRING: la = (atomic)PL_new_string(copy); break;
  }

  free(copy);

  return PL_unify_atomic(l, la);
}


foreign_t
pl_lowercase(u, l)
term u, l;
{ char *copy;
  char *s, *q;
  atomic la;
  int thetype;

  thetype=PL_type(u);
  switch (thetype) {
  case PL_ATOM  : s = PL_atom_value(PL_atomic(u)); break;
  case PL_STRING: s = PL_string_value(PL_atomic(u)); break;
  default: return PL_warning("lowercase/2: instantiation fault in arg 1: string or atom expected");
  }

  copy = (char *) malloc(strlen(s)+1);

  for( q=copy; *s; q++, s++)
    *q = (isupper(*s) ? tolower(*s) : *s);
  *q = '\0';

  switch(thetype) {
  case PL_ATOM  : la = (atomic)PL_new_atom(copy); break;
  case PL_STRING: la = (atomic)PL_new_string(copy); break;
  }

  free(copy);

  return PL_unify_atomic(l, la);
}


/*
 * Text_to_cname -- make a valid C identifier from a text string.
 *
 * We define two predicates here:
 *
 * text_to_cname(+Str1, +Int, -Str2)
 * text_to_cname(+Str1, +Int1, +Int2, -Str2)
 *
 * Both make C identifiers (cnames) from the string Str1 by clipping
 * off any invalid characters. In order to make a comprehensive yet
 * reasonable short name, we use a certain number of characters from
 * each word, which concatenated with each first character
 * capitalized. 
 *   Text_to_cname/3 cuts off any character which is at a position
 * greater than Int1 in each word, whereas text_to_cname/4 uses a more
 * sophisticated method: No word is left longer than Int2. If a word
 * has a length of <= Int2, it is not cut at all. If it's longer, it
 * is cut to a length of Int1. Int1 is usually chosen less than Int2.
 *
 * Example:
 *
 *   text_to_cname("This -- is a, (little) test!", 3, S).
 *   ---> S="ThiIsALitTes"
 *
 *   text_to_cname("This -- is a, (little) test!", 3, 5, S).
 *   ---> S="ThisIsALitTest"
 *
 * A new feature is that any word which begins with a backslash ``\'' is
 * not truncated. This is necessary in order to handle such cases like
 * ``Status'' and ``Station'', which would otherwise become to ``Sta''.
 * Please note, that the ``Dia-log'' vs. ``Dia-gnose'' and ``Patho-logy''
 * vs. ``Radio-logy'' must be handled before text_to_cname works on
 * the string.
 */

#define DIGIT(c) (c>='0' && c<='9')
#define CNAMEC(c) ((c>='a' && c<='z') || (c>='A' && c<='Z') \
		   || c=='_' || DIGIT(c))
#define UNTOUCHABLE(c) (c == '\\')

foreign_t
pl_text_to_cname_3(str, num, res)
term str, num, res;
{ char *argstr, *newstr, *q;
  atomic ress;
  int i, cnt, j;
  int thetype;

  thetype=PL_type(str);
  switch (thetype) {
  case PL_ATOM  : argstr = PL_atom_value(PL_atomic(str)); break;
  case PL_STRING: argstr = PL_string_value(PL_atomic(str)); break;
  default: return PL_warning("text_to_cname/3: instantiation fault in arg 1: string or atom expected");
  }

  if ( !PL_is_int(num) )
    return PL_warning("text_to_cname/3: instantiation fault in arg 2: integer expected");
  cnt = PL_integer_value(PL_atomic(num));
  q = newstr = (char *) malloc(strlen(argstr)+1);


  j=0;
  while (*argstr) {
    while (*argstr && ! CNAMEC(*argstr))
      { argstr++; j++; }

    if (!*argstr) break;

    *q=(islower(*argstr) ? toupper(*argstr) : *argstr);
    argstr++; j++; q++;

    if((j>=2) && UNTOUCHABLE(*(argstr - 2)))
      {
	while(CNAMEC(*argstr))
	  { *q++=*argstr++; j++; }
      }
    else
      {
	for(i=1;(i<cnt) && CNAMEC(*argstr); i++, q++, argstr++, j++)
	  *q=*argstr;
	while (*argstr && CNAMEC(*argstr))
	  { argstr++; j++; }
      }
  } 
  *q = '\0';

  switch(thetype) {
  case PL_ATOM  : ress = (atomic)PL_new_atom(newstr); break;
  case PL_STRING: ress = (atomic)PL_new_string(newstr); break;
  }

  free(newstr);

  return PL_unify_atomic(res, ress);
}

foreign_t
pl_text_to_cname_4(str, num, thresh, res)
term str, num, thresh, res;
{ char *argstr, *newstr, *q;
  atomic ress;
  int i, cnt, thre, j;
  int thetype;

  thetype=PL_type(str);
  switch (thetype) {
  case PL_ATOM  : argstr = PL_atom_value(PL_atomic(str)); break;
  case PL_STRING: argstr = PL_string_value(PL_atomic(str)); break;
  default: return PL_warning("text_to_cname/4: instantiation fault in arg 1: string or atom expected");
  }

  if ( !PL_is_int(num) )
    return PL_warning("text_to_cname/4: instantiation fault in arg 2: integer expected");
  if ( !PL_is_int(thresh) )
    return PL_warning("text_to_cname/4: instantiation fault in arg 3: integer expected");

  cnt = PL_integer_value(PL_atomic(num));
  thre = PL_integer_value(PL_atomic(thresh));
  q = newstr = (char *) malloc(strlen(argstr)+1);

#ifdef DEBUG
  if(logfile == NULL)
    logfile = fopen("T2CN-LOGFILE", "a");
  fprintf(logfile, "%s:%d:%d:", argstr, cnt, thre);
#endif

  j = 0;
  while (*argstr) {
    while (*argstr && ! CNAMEC(*argstr))
      { argstr++; j++; }
    if (!*argstr) break;
    *q=(islower(*argstr)?toupper(*argstr):*argstr);
    argstr++; j++; q++;

    if((j >= 2) && UNTOUCHABLE(*(argstr - 2)))
      {
	while(CNAMEC(*argstr))
	  { *q++=*argstr++; j++; }
      }
    else
      {
	for(i=1;(i<=thre) && CNAMEC(*argstr); i++, q++, argstr++, j++)
	  *q=*argstr;
	if (i<=thre) continue;
	q=q-i+cnt;
	while (*argstr && CNAMEC(*argstr))
	  { argstr++; j++; }
      }
  } 
  *q = '\0';


#ifdef DEBUG
  fprintf(logfile, "%s\n", newstr);
#endif

  switch(thetype) {
  case PL_ATOM  : ress = (atomic)PL_new_atom(newstr); break;
  case PL_STRING: ress = (atomic)PL_new_string(newstr); break;
  }

  free(newstr);

  return PL_unify_atomic(res, ress);
}

/*
 * extract the words of a string into a list
 *
 */
foreign_t
pl_text_to_wlist_2(term str, term wlist)
{ char *argstr;
  char *p;
  char *q;
  int thetype;
  atomic nil;
  functor cons_fun;
  term cons;
  
  thetype=PL_type(str);

  switch (thetype) {
  case PL_ATOM  : argstr = PL_atom_value(PL_atomic(str)); break;
  case PL_STRING: argstr = PL_string_value(PL_atomic(str)); break;
  default: return PL_warning("text_to_wlist/2: instantiation fault in arg 1: string or atom expected");
  }
  
  nil = (atomic)PL_new_atom("[]");
  cons_fun = PL_new_functor(PL_new_atom("."),2); 

  q=strdup(argstr);
  cons = wlist; 

  while((p=strsep(&q," ")) != NULL) {
    if(!PL_unify_functor(cons, cons_fun)) return FALSE;
    if(!PL_unify_atomic(PL_arg(cons,1),PL_new_atom(p))) return FALSE;
    cons=PL_arg(cons,2);
  } 
  free(q);
  
  return PL_unify_atomic(cons,nil);
}


#ifdef WITH_REGSUB
/*
 * substitute with regular expression
 *
 */
foreign_t
pl_regsub_4(term src, term reg, term sub, term dst) {
  char *srcs, *regs, *subs, *dsts, *s, *p, *bnd;
  int srct, regt, subt, pgc;
  atomic dsta;
  regexp *prog;

  srct=PL_type(src);
  switch (srct) {
  case PL_ATOM  : srcs = PL_atom_value(PL_atomic(src)); break;
  case PL_STRING: srcs = PL_string_value(PL_atomic(src)); break;
  default: return PL_warning("regsub/4: instantiation fault in arg 1: string or atom expected");
  }
  
  regt=PL_type(reg);
  switch (srct) {
  case PL_ATOM  : regs = PL_atom_value(PL_atomic(reg)); break;
  case PL_STRING: regs = PL_string_value(PL_atomic(reg)); break;
  default: return PL_warning("regsub/4: instantiation fault in arg 2: string or atom expected");
  }
  
  subt=PL_type(sub);
  switch (subt) {
  case PL_ATOM  : subs = PL_atom_value(PL_atomic(sub)); break;
  case PL_STRING: subs = PL_string_value(PL_atomic(sub)); break;
  default: return PL_warning("regsub/4: instantiation fault in arg 3: string or atom expected");
  }
  
  prog=regcomp(regs);

# define PAGE 1024

  pgc=1;
  p = dsts = (char *)malloc(PAGE);  bnd=dsts+PAGE/2;
  s = srcs;

  while(*s && regexec(prog,s)) {

    if (prog->endp[0] <= prog->startp[0]) {
      free(dsts);
      free(prog);
      return PL_warning("regsub/4: infinite substitution loop");
    }

    while(s<prog->startp[0]) *p++=*s++;

    if(p>bnd) {  /* allocate a new page */
      char *old=dsts;
      dsts=(char *)realloc(dsts, ++pgc*PAGE);
      p=(p-old)+dsts;
      bnd=dsts+pgc*PAGE-PAGE/2;
    }

    /* vulnerable phase, hope that memory is sufficient */
    regsub(prog, subs, p);

    if(p>bnd) {  /* allocate a new page */
      char *old=dsts;
      dsts=(char *)realloc(dsts, ++pgc*PAGE);
      p=(p-old)+dsts;
      bnd=dsts+pgc*PAGE-PAGE/2;
    }

    while(*p) p++;
    s=prog->endp[0];
  }
  do *p++=*s; while(*s++); 
  
  switch(srct) {
  case PL_ATOM  : dsta = (atomic)PL_new_atom(dsts); break;
  case PL_STRING: dsta = (atomic)PL_new_string(dsts); break;
  }

  free(dsts);
  free(prog);

  return PL_unify_atomic(dst, dsta);
}
#endif /* WITH_REGSUB */

/*
 * Interfaces to environ and argv.
 */

foreign_t
pl_arglist(term list)
{
  int argc = PL_query(PL_QUERY_ARGC);
  char **argv = (char **)PL_query(PL_QUERY_ARGV);
  atomic nil = (atomic)PL_new_atom("[]");
  term cons = list; 
  functor cons_fun = PL_new_functor(PL_new_atom("."),2); 
  int i;

  for(i = 0; i < argc; i++)
    {
      if(!PL_unify_functor(cons, cons_fun)) return FALSE;
      if(!PL_unify_atomic(PL_arg(cons,1),PL_new_atom(argv[i]))) return FALSE;
      cons=PL_arg(cons,2);
    } 
  
  return PL_unify_atomic(cons,nil);
}

#if SWIPL < 2
foreign_t
pl_redefine_system_predicate(term str)     
{
  PL_succeed;
}
#endif

#if (SWIPL == 2) || !defined(DYNAMIC_FOREIGN)
PL_extension PL_extensions [] =
{
  { "lowercase",     2,      pl_lowercase,       0},
  { "uppercase",     2,      pl_uppercase,       0},
  { "text_to_cname", 3,      pl_text_to_cname_3, 0},
  { "text_to_cname", 4,      pl_text_to_cname_4, 0},
  { "text_to_wlist", 2,      pl_text_to_wlist_2, 0},
#ifdef WITH_REGSUB
  { "regsub",        4,      pl_regsub_4,        0},
#endif
  { "arglist",       1,      pl_arglist,         0},
#if SWIPL < 2
  { "redefine_system_predicate", 1, pl_redefine_system_predicate, 0},
#endif
  { NULL,	     0,      NULL,		 0}  /* terminating line */
};
#endif /* SWIPL==2 && !DYNAMIC_FOREIGN */

               
# if SWIPL == 2
/*
 * Initialization
 */
int
main(int argc, char *argv[], char *env[])
{
  if(!PL_initialise(argc, argv, env))
    PL_halt(1);

  PL_halt(PL_toplevel() ? 0 : 1);
}
#endif

#ifdef DYNAMIC_FOREIGN
/*
 * Initialization
 */
void
init_pltools() { 
  PL_register_foreign("lowercase", 2, pl_lowercase, 0);
  PL_register_foreign("uppercase", 2, pl_uppercase, 0);
  PL_register_foreign("text_to_cname", 3, pl_text_to_cname_3, 0);
  PL_register_foreign("text_to_cname", 4, pl_text_to_cname_4, 0);
  PL_register_foreign("text_to_wlist", 2, pl_text_to_wlist_2, 0);
#ifdef WITH_REGSUB
  PL_register_foreign("regsub", 4, pl_regsub_4, 0);
#endif
  PL_register_foreign("arglist", 1, pl_arglist, 0);
#if SWIPL < 2
  PL_register_foreign("redefine_system_predicate", 1,
		      pl_redefine_system_predicate, 0);
#endif
}
#endif /* DYNAMIC_FOREIGN */