/*
 *
 * u n i x . c					-- Some Unix primitives
 *
 * Copyright (C) 1993,1994,1995 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
 * 
 *
 * Permission to use, copy, and/or distribute this software and its
 * documentation for any purpose and without fee is hereby granted, provided
 * that both the above copyright notice and this permission notice appear in
 * all copies and derived works.  Fees for distribution or use of this
 * software or derived works may only be charged with express written
 * permission of the copyright holder.  
 * This software is provided ``as is'' without express or implied warranty.
 *
 * This software is a derivative work of other copyrighted softwares; the
 * copyright notices of these softwares are placed in the file COPYRIGHTS
 *
 *
 *           Author: Erick Gallesio [eg@kaolin.unice.fr]
 *    Creation date: 29-Mar-1994 10:57
 * Last file update:  9-Jul-1995 11:58
 */

#include <unistd.h>
#include <pwd.h>
#include <sys/types.h>
#include <sys/stat.h>
#include <dirent.h>
#include "stk.h"


#ifdef SUNOS4
/* I avoid to use the POSIX getcwd since it is implemented using popen(3) and
 * pwd(1) on SunOS 4.1.3 ==> It is VERY SLOW.
 */

#define getcwd my_getcwd
static char *my_getcwd(char *path, int size)
{
  if (!path) path = (char *) must_malloc(size);
  getwd(path);
  return path;
}
#endif  /* SUNOS4 */

/******************************************************************************
 *
 * Utilities
 *
 ******************************************************************************/

/*
 * TILDE-EXPAND		-- expand '~' and '~user' string prefix
 *
 */

static char *tilde_expand(char *name, char *result)
{
  char *dir, *p;

  if (name[0] != '~') {
    strcpy(result, name);
    return name;
  }

  if ((name[1] == '/') || (name[1] == '\0')) {
    dir = getenv("HOME");
    if (dir == NULL)
      Err("couldn't find HOME environment for expanding ", STk_makestring(name));
    
    sprintf(result, "%s%s", dir, name+1);
  } 
  else {
    struct passwd *pwPtr;
    register int len;
    for (p=&name[1]; (*p != 0) && (*p != '/'); p++) {
      /* Null body;  just find end of name. */
    }
    len = p-(name+1);
    strncpy(result, name+1, len);
    result[len] = '\0';

    pwPtr = getpwnam(result);
    if (pwPtr == NULL) {
      endpwent();
      Err("User does not exist", STk_makestring(result));
    }
    sprintf(result, "%s%s", pwPtr->pw_dir, p);
    endpwent();
  }
  return result;
}

/*
 * ABSOLUTE	-- Given a file name, return its (mostly clean) absolute path name
 *
 */
static char *absolute(char *s, char *pathname)	
{
  char *p = pathname;
  char *t;

  if (s[0] != '/') {
    getcwd(pathname, MAX_PATH_LENGTH);
    p = &pathname[strlen(pathname)];     /* place p at end of pathname */ 
  }
  *p = '/';

  for ( ; *s; s++) {
    t = s;
    switch (*s) {
      case '.' : if (*(s+1)) {
	           switch (*++s) {
		     case '.' : if (*p=='/' && (*(s+1)=='\0' || *(s+1)=='/')) { 
			          /* We must go back to the parent */
			          if (*p == '/' && p > pathname) p--;
			          while (p > pathname && *p != '/') p--;
			        }
			        else {
				  /* There is a suit of dot. Copy it */
				  for (s = t; *s == '.'; s++) *++p = '.';
				  s -= 1;
			        }
			        break;
		     case '/' : if (*p != '/') *++p = '/'; 
		                break;
		     default  : *++p = '.'; *++p = *s; break;
		   }
		 }
		 break;
      case '/' : if (*p != '/') *++p = '/'; break;
      default  : *++p = *s;
    }
  }
  
  /* Place a \0 at end. If path ends with a "/", delete it */
  if (p == pathname || *p != '/') p++;
  *p = '\0';
}

/*
 *----------------------------------------------------------------------
 *
 * fileglob --
 *      *****							        ******
 * 	***** This function is an adaptation of the Tcl function DoGlob ******
 *      ***** Adaptated to use true lists rather than string as in Tcl  ******
 *      *****							        ******
 *	
 *
 *      This recursive procedure forms the heart of the globbing
 *      code.  It performs a depth-first traversal of the tree
 *      given by the path name to be globbed.
 *
 * Results:
 *      The return value is a standard Tcl result indicating whether
 *      an error occurred in globbing.  After a normal return the
 *      result in interp will be set to hold all of the file names
 *      given by the dir and rem arguments.  After an error the
 *      result in interp will hold an error message.
 *
 * Side effects:
 *      None.
 *
 *----------------------------------------------------------------------
 */

static SCM fileglob(char *dir, char *rem, SCM result)
/* dir: Name of a directory at which to start glob expansion.  This name
 * is fixed: it doesn't contain any globbing chars. 
 * rem: Path to glob-expand.
 */
{
  /*
   * When this procedure is entered, the name to be globbed may
   * already have been partly expanded by ancestor invocations of
   * fileglob.  The part that's already been expanded is in "dir"
   * (this may initially be empty), and the part still to expand
   * is in "rem".  This procedure expands "rem" one level, making
   * recursive calls to itself if there's still more stuff left
   * in the remainder.
   */
  
  Tcl_DString newName;                /* Holds new name consisting of
				       * dir plus the first part of rem. */
  register char *p;
  register char c;
  char *openBrace, *closeBrace, *name, *dirName;
  int gotSpecial, baseLength;
  struct stat statBuf;

  /*
   * Make sure that the directory part of the name really is a
   * directory.  If the directory name is "", use the name "."
   * instead, because some UNIX systems don't treat "" like "."
   * automatically. Keep the "" for use in generating file names,
   * otherwise "glob foo.c" would return "./foo.c".
   */
  
  dirName = (*dir == '\0') ? ".": dir;
  if ((stat(dirName, &statBuf) != 0) || !S_ISDIR(statBuf.st_mode))
    return result;

  Tcl_DStringInit(&newName);

  /*
   * First, find the end of the next element in rem, checking
   * along the way for special globbing characters.
   */
  
  gotSpecial = 0;
  openBrace = closeBrace = NULL;
  for (p = rem; ; p++) {
    c = *p;
    if ((c == '\0') || ((openBrace == NULL) && (c == '/'))) break;
    if ((c == '{')  && (openBrace == NULL)) openBrace = p;
    if ((c == '}')  && (openBrace != NULL) && (closeBrace == NULL)) closeBrace = p;
    if ((c == '*') || (c == '[') || (c == '\\') || (c == '?')) gotSpecial = 1;
  }

  /*
   * If there is an open brace in the argument, then make a recursive
   * call for each element between the braces.  In this case, the
   * recursive call to fileglob uses the same "dir" that we got.
   * If there are several brace-pairs in a single name, we just handle
   * one here, and the others will be handled in recursive calls.
   */

  if (openBrace != NULL) {
    char *element;
    
    if (closeBrace == NULL) {
      Tcl_DStringFree(&newName);      
      Err("unmatched open-brace in file name", NIL);
    }

    Tcl_DStringAppend(&newName, rem, openBrace-rem);
    baseLength = newName.length;
    for (p = openBrace; *p != '}'; ) {
      element = p+1;
      for (p = element; ((*p != '}') && (*p != ',')); p++) {}
      Tcl_DStringAppend(&newName, element, p-element);
      Tcl_DStringAppend(&newName, closeBrace+1, -1);
      result = fileglob(dir, newName.string, result);
      newName.length = baseLength;
    }
    goto done;
  }

  /*
   * Start building up the next-level name with dir plus a slash if
   * needed to separate it from the next file name.
   */

  Tcl_DStringAppend(&newName, dir, -1);
  if ((dir[0] != 0) && (newName.string[newName.length-1] != '/')) {
    Tcl_DStringAppend(&newName, "/", 1);
  }
  baseLength = newName.length;

  /*
   * If there were any pattern-matching characters, then scan through
   * the directory to find all the matching names.
   */

  if (gotSpecial) {
    DIR *d;
    struct dirent *entryPtr;
    char savedChar;

    d = opendir(dirName);
    if (d == NULL) {
      Tcl_DStringFree(&newName);
      Err("cannot read directory", STk_makestring(dirName));
    }

    /*
     * Temporarily store a null into rem so that the pattern string
     * is now null-terminated.
     */

    savedChar = *p;
    *p = 0;

    while (1) {
      entryPtr = readdir(d);
      if (entryPtr == NULL) break;
      /*
       * Don't match names starting with "." unless the "." is
       * present in the pattern.
       */
      if ((*entryPtr->d_name == '.') && (*rem != '.')) continue;

      if (Tcl_StringMatch(entryPtr->d_name, rem)) {
	newName.length = baseLength;
	Tcl_DStringAppend(&newName, entryPtr->d_name, -1);
	if (savedChar == 0)
	  result = Cons(STk_makestring(newName.string), result);
	else {
	  result = fileglob(newName.string, p+1, result);
	  if (result != TCL_OK) break;
	}
      }
      
    }
    closedir(d);
    *p = savedChar;
    goto done;
  }

  /*
   * The current element is a simple one with no fancy features.  Add
   * it to the new name.  If there are more elements still to come,
   * then recurse to process them.
   */
  
  Tcl_DStringAppend(&newName, rem, p-rem);
  if (*p != 0) {
    result = fileglob(newName.string, p+1, result);
    goto done;
  }

  /*
   * There are no more elements in the pattern.  Check to be sure the
   * file actually exists, then add its name to the list being formed
   * in main_interp-result.
   */

  name = newName.string;
  if (*name == 0) name = ".";
  if (access(name, F_OK) != 0) goto done;
  result = Cons(STk_makestring(name), result);
done:
  Tcl_DStringFree(&newName);
  return result;
}

SCM STk_internal_expand_file_name(char *s)
{
  char expanded[2 * MAX_PATH_LENGTH], abs[2 * MAX_PATH_LENGTH];  
  /* Warning: absolute makes no control about path overflow. Hence the "2 *" */

  absolute(tilde_expand(s, expanded), abs);
  return STk_makestring(abs);
}


void STk_whence(char *exec, char *path)
{
  char *p, *q, dir[MAX_PATH_LENGTH];
  struct stat buf;
 
  if (*exec == '/') {
    strncpy(path, exec, MAX_PATH_LENGTH);
    return;
  }

#ifdef FREEBSD 
  /* I don't understand why this is needed */
  if (access(path, X_OK) == 0) {
    stat(path, &buf);
    if (!S_ISDIR(buf.st_mode)) return;
  }  
#endif

  p = getenv("PATH");
  while (*p) {
    /* Copy the stuck of path in dir */
    for (q = dir; *p && *p != ':'; p++, q++) *q = *p;
    *q = '\000';

    sprintf(path, "%s/%s", dir, exec);
    if (access(path, X_OK) == 0) {
      stat(path, &buf);
      if (!S_ISDIR(buf.st_mode)) return;
    }
    
    /* Try next path */
    if (*p) p++;
  }
  /* Not found. Set path to "" */
  path[0] = '\0';
}

int STk_dirp(const char *path)
{
  struct stat buf;

  if (stat(path, &buf) >= 0) 
    return S_ISDIR(buf.st_mode);
  return FALSE;
}


/******************************************************************************
 *
 * Primitives
 *
 ******************************************************************************/

PRIMITIVE STk_expand_file_name(SCM s)
{
  if (NSTRINGP(s)) Err("expand-file-name: bad string", s);
  return STk_internal_expand_file_name(CHARS(s));
}

PRIMITIVE STk_getcwd(void)
{
  
  char *buf = (char *)getcwd(NULL, MAX_PATH_LENGTH);
  SCM z;

  if (!buf) Err("getcwd: cannot allocate space", NIL);
  z = STk_makestring(buf);
  free(buf);

  return z;
}

PRIMITIVE STk_chdir(SCM s)
{
  if (NSTRINGP(s)) Err("chdir: bad string", s);
  
  if (chdir(CHARS(STk_internal_expand_file_name(CHARS(s)))))
    Err("chdir: cannot change directory to", s);
  return UNDEFINED;
}

PRIMITIVE STk_getpid(void)
{
  return (STk_makeinteger((int) getpid()));
}

PRIMITIVE STk_system(SCM com)
{
  if (NSTRINGP(com)) Err("system: not a string", com);
  return STk_makeinteger(system(CHARS(com)));
}
    
PRIMITIVE STk_getenv(SCM str)
{
  char *tmp;
  if (NSTRINGP(str)) Err("getenv: not a string", str);
  tmp = getenv(CHARS(str));
  return tmp ? STk_makestring(tmp) : Ntruth;
}


/******************************************************************************
 *
 * file-is-xxx? primitives
 *
 ******************************************************************************/

static SCM my_access(SCM path, int mode, char *who)
{
  if (NSTRINGP(path)) {
    char buff[100];
    sprintf(buff, "%s: bad string", who);
    Err(buff, path);
  }
  
  return (access(CHARS(path), mode) == 0) ? Truth: Ntruth;
}


static SCM my_stat(SCM path, int mode, char *who)
{
  struct stat info;
  
  if (NSTRINGP(path)) {
    char buff[100];
    sprintf(buff, "%s: bad string", who);
    Err(buff, path);
  }

  if (stat(CHARS(path), &info) != 0) return Ntruth;

  switch (mode) {
    case 1: return (S_ISDIR(info.st_mode)) ? Truth : Ntruth;
    case 2: return (S_ISREG(info.st_mode)) ? Truth : Ntruth;
  }
}

PRIMITIVE STk_file_is_directoryp(SCM f)
{
  return my_stat(f, 1, "file-is-directory?");
}

PRIMITIVE STk_file_is_regularp(SCM f)
{
  return my_stat(f, 2, "file-is-regular?");
}

PRIMITIVE STk_file_is_readablep(SCM f)
{
  return my_access(f, R_OK, "file-is-readable?");
}

PRIMITIVE STk_file_is_writablep(SCM f)
{
  return my_access(f, W_OK, "file-is-writable?");
}

PRIMITIVE STk_file_is_executablep(SCM f)
{
  return my_access(f, X_OK, "file-is-executable?");
}

PRIMITIVE STk_file_existp(SCM f)
{
  return my_access(f, F_OK, "file-exists?");
}


PRIMITIVE STk_file_glob(SCM l, int len) /* len is unused here */
{
  SCM res = NIL;
  char s[2*MAX_PATH_LENGTH];
  
  for ( ; NNULLP(l); l = CDR(l)) {
    if (NSTRINGP(CAR(l))) Err("glob: bad string", CAR(l));
    
    tilde_expand(CHARS(CAR(l)), s);

    res = STk_append(LIST2(res, 
			   (*s == '/') ? fileglob("/", s+1, NIL) :
			                 fileglob("", s, NIL)),
		     2);
  }
  return res;
}