retoglob.c

/*
 * re2glob - C implementation
 * (c) 2007 ActiveState Software Inc.
 */

#include <tcl.h>

#define DEBUG 0

static void
ExpChopNested _ANSI_ARGS_ ((Tcl_UniChar** xstr,
			    int*          xstrlen,
			    Tcl_UniChar   open,
			    Tcl_UniChar   close));

static Tcl_UniChar*
ExpLiteral _ANSI_ARGS_ ((Tcl_UniChar* nexto,
			 Tcl_UniChar* str,
			 int          strlen));

static Tcl_UniChar*
ExpCollapseStar _ANSI_ARGS_ ((Tcl_UniChar* src,
			      Tcl_UniChar* last));
static Tcl_UniChar*
ExpCollapseQForward _ANSI_ARGS_ ((Tcl_UniChar* src,
				  Tcl_UniChar* last));

static Tcl_UniChar*
ExpCollapseQBack _ANSI_ARGS_ ((Tcl_UniChar* src,
			       Tcl_UniChar* last));

static Tcl_UniChar
ExpBackslash _ANSI_ARGS_ ((char prefix,
			 Tcl_UniChar* str,
			 int          strlen));

static int
ExpCountStar _ANSI_ARGS_ ((Tcl_UniChar* src, Tcl_UniChar* last));


static char*
xxx (Tcl_UniChar* x, int xl)
{
  static Tcl_DString ds;
  Tcl_DStringInit (&ds);
  return Tcl_UniCharToUtfDString (x,xl,&ds);
}


Tcl_Obj*
exp_retoglob (
    Tcl_UniChar* str,
    int          strlen)
{
  /*
   * Output: x2 size of input (literal where every character has to be
   * quoted.
   * Location: For next translated unit, in output.
   * Size of last generated unit, in characters.
   * Stack of output locations at opening parens. x1 size of input.
   * Location for next location on stack.
   */

  static Tcl_UniChar litprefix [] = {'*','*','*','='};
  static Tcl_UniChar areprefix [] = {'*','*','*',':'};
  static Tcl_UniChar areopts   [] = {'(','?'};
  static Tcl_UniChar nocapture [] = {'?',':'};
  static Tcl_UniChar lookhas   [] = {'?','='};
  static Tcl_UniChar looknot   [] = {'?','!'};
  static Tcl_UniChar xcomment  [] = {'?','#'};

  static Tcl_UniChar classa  [] = {'[','.'};
  static Tcl_UniChar classb  [] = {'[','='};
  static Tcl_UniChar classc  [] = {'[',':'};


  int lastsz, expanded;
  Tcl_UniChar*  out;
  Tcl_UniChar*  nexto;
  Tcl_UniChar** paren;
  Tcl_UniChar** nextp;
  Tcl_Obj*     glob = NULL;
  Tcl_UniChar* mark;
  Tcl_UniChar  ch;

  /*
   * Set things up.
   */

  out    = nexto = (Tcl_UniChar*)  Tcl_Alloc (strlen*2*sizeof (Tcl_UniChar));
  paren  = nextp = (Tcl_UniChar**) Tcl_Alloc (strlen*  sizeof (Tcl_UniChar*));
  lastsz = -1;
  expanded = 0;

  /*
   * Start processing ...
   */

#define CHOP(n)  {str += (n); strlen -= (n);}
#define CHOPC(c) {while (*str != (c) && strlen) CHOP(1) ;}
#define EMIT(c)  {lastsz = 1; *nexto++ = (c);}
#define EMITX(c) {lastsz++;   *nexto++ = (c);}
#define MATCH(lit) ((strlen >= (sizeof (lit)/sizeof (Tcl_UniChar))) && (0 == Tcl_UniCharNcmp (str,(lit),sizeof(lit)/sizeof (Tcl_UniChar))))
#define MATCHC(c) (strlen && (*str == (c)))
#define PUSHPAREN {*nextp++ = nexto;}
#define UNEMIT {nexto -= lastsz; lastsz = -1;}
  /* Tcl_UniCharIsDigit ? */
#define MATCH_DIGIT (MATCHC ('0') || MATCHC ('1') || \
	  MATCHC ('2') || MATCHC ('3') || \
	  MATCHC ('4') || MATCHC ('5') || \
	  MATCHC ('6') || MATCHC ('7') || \
	  MATCHC ('8') || MATCHC ('9'))
#define MATCH_HEXDIGIT (MATCH_DIGIT || \
		       MATCHC ('a') || MATCHC ('A') || \
		       MATCHC ('b') || MATCHC ('B') || \
		       MATCHC ('c') || MATCHC ('C') || \
		       MATCHC ('d') || MATCHC ('D') || \
		       MATCHC ('e') || MATCHC ('E') || \
		       MATCHC ('f') || MATCHC ('F'))
#define EMITC(c) {if (((c) == '\\') || \
		      ((c) == '*') || \
		      ((c) == '?') || \
		      ((c) == '$') || \
		      ((c) == '^') || \
		      ((c) == '[')) { \
			EMIT ('\\'); EMITX ((c)); \
		      } else { \
			EMIT ((c));}}
#define MATCH_AREOPTS(c) (c == 'b' || c == 'c' || \
          c == 'e' || c == 'i' || c == 'm' || c == 'n' || \
          c == 'p' || c == 'q' || c == 's' || c == 't' || \
          c == 'w' || c == 'x')

#if DEBUG
#define LOG if (1) fprintf
#define FF fflush (stderr)
#define MARK(s) LOG (stderr,#s "\n"); FF;
#else
#define LOG if (0) fprintf
#define FF 
#define MARK(s) 
#endif

  /* ***= -> literal string follows */

  LOG (stderr,"RE-2-GLOB '%s'\n", xxx(str,strlen)); FF;

  if (MATCH (litprefix)) {
    CHOP (4);
    nexto = ExpLiteral (nexto, str, strlen);
    goto done;
  }

  /* ***: -> RE is ARE. Always for Expect. Therefore ignore */

  if (MATCH (areprefix)) {
    CHOP (4);
    LOG (stderr,"ARE '%s'\n", xxx(str,strlen)); FF;
  }

  /* (?xyz) ARE options, in {bceimnpqstwx}. Not validating that the
   * options are legal. We assume that the RE is valid.
   */

  if (MATCH (areopts)) { /* "(?" */
    Tcl_UniChar* save = str;
    Tcl_UniChar* stop;
    int stoplen;
    int save_strlen = strlen;
    int all_ARE_opts = 1;

    /* First, ensure that this is actually an ARE opts string.
     * It could be something else (e.g., a non-capturing block).
     */
    CHOP (2);
    mark = str; CHOPC (')');
    stop = str;       /* Remember closing parens location, allows */
    stoplen = strlen; /* us to avoid a second CHOPC run later */

    while (mark < str) {
      if (MATCH_AREOPTS(*mark)) {
        mark++;
      } else {
        all_ARE_opts = 0;
        break;
      }
    }

    /* Reset back to our entry point. */
    str    = save;
    strlen = save_strlen;

    if (all_ARE_opts) {
      /* Now actually perform the ARE option processing */
      LOG (stderr, "%s\n", "Processing AREOPTS"); FF;

      CHOP (2);
      mark = str;
      /* Equivalent to CHOPC (')') */
      str    = stop; 
      strlen = stoplen;

      while (mark < str) {
        if (*mark == 'q') {
          CHOP (1);
          nexto = ExpLiteral (nexto, str, strlen);
          goto done;
        } else if (*mark == 'x') {
          expanded = 1;
          LOG (stderr,"EXPANDED\n"); FF;
        }
        mark++;
      }
      CHOP (1);
    }
  }

  while (strlen) {

    LOG (stderr,"'%s' <-- ",xxx(out,nexto-out)); FF;
    LOG (stderr,"'%s'\n",   xxx(str,strlen));    FF;

    if (expanded) {
      /* Expanded syntax, whitespace and comments, ignore. */
      while (MATCHC (' ')  ||
	     MATCHC (0x9) ||
	     MATCHC (0xa)) CHOP (1);
      if (MATCHC ('#')) {
	CHOPC (0xa);
	if (strlen) CHOP (1);
	continue;
      }
    }

    if (MATCHC ('|')) {
      /* branching is too complex */
      goto error;
    } else if (MATCHC ('(')) {
      /* open parens */
      CHOP (1);
      if (MATCH (nocapture)) { /* "?:" */
	/* non capturing -save location */
	PUSHPAREN;
	CHOP (2);
      } else if (MATCH (lookhas) || /* "?=" */
		 MATCH (looknot)) { /* "?!" */
	/* lookahead - ignore */
	CHOP (2);
	ExpChopNested (&str, &strlen, '(', ')');
      } else if (MATCH (xcomment)) { /* "?#" */
	/* comment - ignore */
	CHOPC (')'); CHOP (1);
      } else {
	/* plain capturing */
	PUSHPAREN;
      }
    } else if (MATCHC (')')) {
      /* Closing parens. */
      CHOP (1);
      /* Everything coming after the saved result is new, and
       * collapsed into a single entry for a possible coming operator
       * to handle.
       */
      nextp --; /* Back to last save */
      mark   = *nextp; /* Location where generation for this parens started */
      lastsz = (nexto - mark); /* This many chars generated */
      /* Now lastsz has the correct value for a possibly following
       * UNEMIT
       */
    } else if (MATCHC ('$') || MATCHC ('^')) {
      /* anchor constraints - ignore */
      CHOP (1);
    } else if (MATCHC ('[')) {
      /* Classes - reduce to any char [[=chars=]] [[.chars.]]
       * [[:name:]] [chars] Count brackets to find end.

       * These are a bit complicated ... [= =], [. .], [: {] sequences
       * always have to be complete. '[' does NOT nest otherwise.  And
       * a ']' after the opening '[' (with only '^' allowed to
       * intervene is a character, not the closing bracket. We have to
       * process the class in pieces to handle all this. The Tcl level
       * implementations (0-2 all have bugs one way or other, all
       * different.
       */

      int first   = 1;
      int allowed = 1;
      CHOP (1);
      while (strlen) {
	if (first && MATCHC ('^')) {
	  /* ^ as first keeps allowed ok for one more cycle */
	  CHOP (1);
	  first = 0;
	  continue;
	} else if (allowed && MATCHC (']')) {
	  /* Not a closing bracket! */
	  CHOP (1);
	} else if (MATCHC (']')) {
	  /* Closing bracket found */
	  CHOP (1);
	  break;
	} else if (MATCH (classa) ||
		   MATCH (classb) ||
		   MATCH (classc)) {
	  Tcl_UniChar delim[2];
	  delim[0] = str [1];
	  delim[1] = ']';
	  CHOP (2);
	  while (!MATCH (delim)) CHOP (1);
	  CHOP (2);
	} else {
	  /* Any char in class */
	  CHOP (1);
	}
	/* Reset flags handling start of class */
	allowed = first = 0;
      }

      EMIT ('?');
    } else if (MATCHC ('\\')) {
      /* Escapes */
      CHOP (1);
      if (MATCHC ('d') || MATCHC ('D') ||
	  MATCHC ('s') || MATCHC ('S') ||
	  MATCHC ('w') || MATCHC ('W')) {
	/* Class shorthands - reduce to any char */
	EMIT ('?');
	CHOP (1);
      } else if (MATCHC ('m') || MATCHC ('M') ||
		 MATCHC ('y') || MATCHC ('Y') ||
		 MATCHC ('A') || MATCHC ('Z')) {
	/* constraint escapes - ignore */
	CHOP (1);
      } else if (MATCHC ('B')) {
	/* Backslash */
	EMIT  ('\\');
	EMITX ('\\');
	CHOP (1);
      } else if (MATCHC ('0')) {
	/* Escape NULL */
	EMIT ('\0');
	CHOP (1);
      } else if (MATCHC ('e')) {
	/* Escape ESC */
	EMIT ('\033');
	CHOP (1);
      } else if (MATCHC ('a')) {
	/* Escape \a */
	EMIT (0x7);
	CHOP (1);
      } else if (MATCHC ('b')) {
	/* Escape \b */
	EMIT (0x8);
	CHOP (1);
      } else if (MATCHC ('f')) {
	/* Escape \f */
	EMIT (0xc);
	CHOP (1);
      } else if (MATCHC ('n')) {
	/* Escape \n */
	EMIT (0xa);
	CHOP (1);
      } else if (MATCHC ('r')) {
	/* Escape \r */
	EMIT (0xd);
	CHOP (1);
      } else if (MATCHC ('t')) {
	/* Escape \t */
	EMIT (0x9);
	CHOP (1);
      } else if (MATCHC ('v')) {
	/* Escape \v */
	EMIT (0xb);
	CHOP (1);
      } else if (MATCHC ('c') && (strlen >= 2)) {
	/* Escape \cX - reduce to (.) */
	EMIT ('?');
	CHOP (2);
      } else if (MATCHC ('x')) {
	CHOP (1);
	if (MATCH_HEXDIGIT) {
	  /* Escape hex character */
	  mark = str;
	  while (MATCH_HEXDIGIT) CHOP (1);
	  if ((str - mark) > 2) { mark = str - 2; }
	  ch = ExpBackslash ('x',mark,str-mark);
	  EMITC (ch);
	} else {
	  /* Without hex digits following this is a plain char */
	  EMIT ('x');
	}
      } else if (MATCHC ('u')) {
	/*  Escapes unicode short. */
	CHOP (1);
	mark = str;
	CHOP (4);
	ch = ExpBackslash ('u',mark,str-mark);
	EMITC (ch);
      } else if (MATCHC ('U')) {
	/* Escapes unicode long. */
	CHOP (1);
	mark = str;
	CHOP (8);
	ch = ExpBackslash ('U',mark,str-mark);
	EMITC (ch);
      } else if (MATCH_DIGIT) {
	/* Escapes, octal, and backreferences - reduce (.*) */
	CHOP (1);
	while (MATCH_DIGIT) CHOP (1);
	EMIT ('*');
      } else {
	/* Plain escaped characters - copy over, requote */
	EMITC (*str);
	CHOP (1);
      }
    } else if (MATCHC ('{')) {
      /* Non-greedy and greedy bounds - reduce to (*) */
      CHOP (1);
      if (MATCH_DIGIT) {
	/* Locate closing brace and remove operator */
	CHOPC ('}'); CHOP (1);
	/* Remove optional greedy quantifier */
	if (MATCHC ('?')) { CHOP (1);}
	UNEMIT;
	EMIT ('*');
      } else {
	/* Brace is plain character, copy over */
	EMIT ('{');
	/* CHOP already done */
      }
    } else if (MATCHC ('*') ||
	       MATCHC ('+') ||
	       MATCHC ('?')) {
      /* (Non-)greedy operators - reduce to (*) */
      CHOP (1);
      /* Remove optional greedy quantifier */
      if (MATCHC ('?')) { CHOP (1);}
      UNEMIT;
      EMIT ('*');
    } else if (MATCHC ('.')) {
      /* anychar - copy over */
      EMIT ('?');
      CHOP (1);
    } else {
      /* Plain char, copy over. */
      EMIT (*str);
      CHOP (1);
    }
  }

  LOG (stderr,"'%s' <-- ",xxx(out,nexto-out)); FF;
  LOG (stderr,"'%s'\n",   xxx(str,strlen));    FF;

  /*
   * Clean up the output a bit (collapse *-sequences and absorb ?'s
   * into adjacent *'s.
   */

  MARK (QF)
  nexto = ExpCollapseQForward (out,nexto);
  LOG (stderr,"QF '%s'\n",xxx(out,nexto-out)); FF;

  MARK (QB)
  nexto = ExpCollapseQBack    (out,nexto);
  LOG (stderr,"QB '%s'\n",xxx(out,nexto-out)); FF;

  MARK (QS)
  nexto = ExpCollapseStar     (out,nexto);
  LOG (stderr,"ST '%s'\n",xxx(out,nexto-out)); FF;

  /*
   * Heuristic: if there are more than two *s, the risk is far too
   * large that the result actually is slower than the normal re
   * matching.  So bail out.
   */
  if (ExpCountStar (out,nexto) > 2) {
      goto error;
  }

  /*
   * Check if the result is actually useful.
   * Empty or just a *, or ? are not. A series
   * of ?'s is borderline, as they semi-count
   * the buffer.
   */

  if ((nexto == out) ||
      (((nexto-out) == 1) &&
       ((*out == '*') ||
	(*out == '?')))) {
    goto error;
  }

  /*
   * Result generation and cleanup.
   */
 done:
  LOG (stderr,"RESULT_ '%s'\n", xxx(out,nexto-out)); FF;
  glob = Tcl_NewUnicodeObj (out,(nexto-out));
  goto cleanup;

 error:
  LOG (stderr,"RESULT_ ERROR\n"); FF;

 cleanup:
  Tcl_Free ((char*)out);
  Tcl_Free ((char*)paren);

  return glob;
}

static void
#ifdef _AIX
ExpChopNested (Tcl_UniChar** xstr,
	       int*          xstrlen,
	       Tcl_UniChar   open,
	       Tcl_UniChar   close)
#else
ExpChopNested (xstr,xstrlen, open, close)
     Tcl_UniChar** xstr;
     int*          xstrlen;
     Tcl_UniChar   open;
     Tcl_UniChar   close;
#endif
{
  Tcl_UniChar* str    = *xstr;
  int          strlen = *xstrlen;
  int          level = 0;

  while (strlen) {
    if (MATCHC (open)) {
      level ++;
    } else if (MATCHC (close)) {
      level --;
      if (level < 0) {
	CHOP (1);
	break;
      }
    }
    CHOP (1);
  }

  *xstr = str;
  *xstrlen = strlen;
}

static Tcl_UniChar*
ExpLiteral (nexto, str, strlen)
     Tcl_UniChar* nexto;
     Tcl_UniChar* str;
     int          strlen;
{
  int lastsz;

  LOG (stderr,"LITERAL '%s'\n", xxx(str,strlen)); FF;

  while (strlen) {
    EMITC (*str);
    CHOP (1);
  }
  return nexto;
}

static Tcl_UniChar
#ifdef _AIX
ExpBackslash (char prefix,
	      Tcl_UniChar* str,
	      int          strlen)
#else
ExpBackslash (prefix, str, strlen)
     char prefix;
     Tcl_UniChar* str;
     int          strlen;
#endif
{
  /* strlen <= 8 */
  char buf[20];
  char dst[TCL_UTF_MAX+1];
  Tcl_UniChar ch;
  int at = 0;

  /* Construct an utf backslash sequence we can throw to Tcl */

  buf [at++] = '\\';
  buf [at++] = prefix;
  while (strlen) {
    buf [at++] = *str++;
    strlen --;
  }

  Tcl_UtfBackslash (buf, NULL, dst);
  TclUtfToUniChar (dst, &ch);
  return ch;
}

static Tcl_UniChar*
ExpCollapseStar (src, last)
     Tcl_UniChar* src;
     Tcl_UniChar* last;
{
  Tcl_UniChar* dst, *base;
  int skip = 0;
  int star = 0;

  /* Collapses series of *'s into a single *. State machine. The
   * complexity is due to the need of handling escaped characters.
   */

  LOG (stderr,"Q-STAR\n"); FF;

  for (dst = base = src; src < last;) {

    LOG (stderr,"@%1d /%1d '%s' <-- ", star,skip,xxx(base,dst-base)); FF;
    LOG (stderr,"'%s'\n",   xxx(src,last-src));  FF;

    if (skip) {
      skip = 0;
      star = 0;
    } else if (*src == '\\') {
      skip = 1; /* Copy next char, whatever its value */
      star = 0;
    } else if (*src == '*') {
      if (star) {
	/* Previous char was *, do not copy the current * to collapse
	 * the sequence
	 */
	src++;
	continue;
      }
      star = 1; /* *-series starts here */
    } else {
      star = 0;
    }
    *dst++ = *src++;
  }

  LOG (stderr,"@%1d /%1d '%s' <-- ", star,skip,xxx(base,dst-base)); FF;
  LOG (stderr,"'%s'\n",   xxx(src,last-src));  FF;

  return dst;
}

static Tcl_UniChar*
ExpCollapseQForward (src, last)
     Tcl_UniChar* src;
     Tcl_UniChar* last;
{
  Tcl_UniChar* dst, *base;
  int skip = 0;
  int quest = 0;

  /* Collapses series of ?'s coming after a *. State machine. The
   * complexity is due to the need of handling escaped characters.
   */

  LOG (stderr,"Q-Forward\n"); FF;

  for (dst = base = src; src < last;) {

    LOG (stderr,"?%1d /%1d '%s' <-- ", quest,skip,xxx(base,dst-base)); FF;
    LOG (stderr,"'%s'\n",   xxx(src,last-src));  FF;

    if (skip) {
      skip = 0;
      quest = 0;
    } else if (*src == '\\') {
      skip = 1;
      quest = 0;
      /* Copy next char, whatever its value */
    } else if (*src == '?') {
      if (quest) {
	/* Previous char was *, do not copy the current ? to collapse
	 * the sequence
	 */
	src++;
	continue;
      }
    } else if (*src == '*') {
      quest = 1;
    } else {
      quest = 0;
    }
    *dst++ = *src++;
  }

  LOG (stderr,"?%1d /%1d '%s' <-- ", quest,skip,xxx(base,dst-base)); FF;
  LOG (stderr,"'%s'\n",   xxx(src,last-src));  FF;
  return dst;
}

static Tcl_UniChar*
ExpCollapseQBack (src, last)
     Tcl_UniChar* src;
     Tcl_UniChar* last;
{
  Tcl_UniChar* dst, *base;
  int skip = 0;

  /* Collapses series of ?'s coming before a *. State machine. The
   * complexity is due to the need of handling escaped characters.
   */

  LOG (stderr,"Q-Backward\n"); FF;

  for (dst = base = src; src < last;) {
    LOG (stderr,"/%1d '%s' <-- ",skip,xxx(base,dst-base)); FF;
    LOG (stderr,"'%s'\n",   xxx(src,last-src));  FF;

    if (skip) {
      skip = 0;
    } else if (*src == '\\') {
      skip = 1;
      /* Copy next char, whatever its value */
    } else if (*src == '*') {
      /* Move backward in the output while the previous character is
       * an unescaped question mark. If there is a previous character,
       * or a character before that..
       */

      while ((((dst-base) > 2)  && (dst[-1] == '?') && (dst[-2] != '\\')) ||
	     (((dst-base) == 1) && (dst[-1] == '?'))) {
	dst --;
      }
    }
    *dst++ = *src++;
  }

  LOG (stderr,"/%1d '%s' <-- \n",skip,xxx(base,dst-base)); FF;
  LOG (stderr,"'%s'\n",   xxx(src,last-src));  FF;
  return dst;
}

static int
ExpCountStar (src, last)
    Tcl_UniChar* src;
    Tcl_UniChar* last;
{
    int skip = 0;
    int stars = 0;

    /* Count number of *'s. State machine. The complexity is due to the
     * need of handling escaped characters.
     */

    for (; src < last; src++) {
	if (skip) {
	    skip = 0;
	} else if (*src == '\\') {
	    skip = 1;
	} else if (*src == '*') {
	    stars++;
	}
    }

    return stars;
}

#undef CHOP
#undef CHOPC
#undef EMIT
#undef EMITX
#undef MATCH
#undef MATCHC
#undef MATCH_DIGIT
#undef MATCH_HEXDIGIT
#undef PUSHPAREN
#undef UNEMIT