/*  Part of SWI-Prolog

    Author:        Jan Wielemaker
    E-mail:        J.Wielemaker@vu.nl
    WWW:           http://www.swi-prolog.org
    Copyright (c)  2011-2023, University of Amsterdam
                              VU University Amsterdam
			      CWI, Amsterdam
			      SWI-Prolog Solutions b.v.
    All rights reserved.

    Redistribution and use in source and binary forms, with or without
    modification, are permitted provided that the following conditions
    are met:

    1. Redistributions of source code must retain the above copyright
       notice, this list of conditions and the following disclaimer.

    2. Redistributions in binary form must reproduce the above copyright
       notice, this list of conditions and the following disclaimer in
       the documentation and/or other materials provided with the
       distribution.

    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
    "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
    LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
    FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
    COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
    INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
    BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
    LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
    CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
    LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
    ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
    POSSIBILITY OF SUCH DAMAGE.
*/

#ifdef __WINDOWS__
#include <winsock2.h>
#include <windows.h>
#endif

#include "pl-incl.h"
#include "pl-utf8.h"
#include "../pl-fli.h"
#include <stdio.h>
#include <errno.h>

#ifdef HAVE_SYS_STAT_H
#include <sys/stat.h>
#endif

#ifdef O_XOS
#define statstruct struct _stati64
#else
#define statstruct struct stat
#define statfunc stat
#endif

#undef LD
#define LD LOCAL_LD

		 /*******************************
		 *	      OS STUFF		*
		 *******************************/

/** int LastModifiedFile(const char *file, double *t)

Return the last modification time of file  as a POSIX timestamp. Returns
(time_t)-1 on failure.

Contains a 64-bit value representing the number of 100-nanosecond
intervals since January 1, 1601 (UTC).
*/

int
LastModifiedFile(const char *name, double *tp)
{
#ifdef O_XOS
  return _xos_get_file_time(name, XOS_TIME_MODIFIED, tp) == 0;
#else
  char tmp[PATH_MAX];
  statstruct buf;

  if ( statfunc(OsPath(name, tmp), &buf) < 0 )
    return FALSE;

#ifdef HAVE_STRUCT_STAT_ST_MTIM
  *tp = (double)buf.st_mtim.tv_sec + (double)buf.st_mtim.tv_nsec/1.0e9;
#else
  *tp = (double)buf.st_mtime;
#endif

  return TRUE;
#endif
}


/** static int64_t SizeFile(const char *path)

Return the size of the file path in bytes. Returns -1 if the file cannot
be accessed.
*/

static int64_t
SizeFile(const char *path)
{
#if O_XOS
  uint64_t size;

  if ( _xos_file_size(path, &size) == 0 )
    return (int64_t)size;

  return -1;
#else
  char tmp[PATH_MAX];
  statstruct buf;

  if ( statfunc(OsPath(path, tmp), &buf) < 0 )
    return -1;

  return buf.st_size;
#endif
}


/** int AccessFile(const char *path, int mode)

TRUE if path can be accessed in the   specified modes. Mode is a bitwise
or created from one or more  of the constants ACCESS_EXIST, ACCESS_READ,
ACCESS_WRITE and ACCESS_EXECUTE.
*/

#ifndef F_OK
#define F_OK 0
#endif

static int
access_mode(int mode)
{ int m = 0;

  if ( mode == ACCESS_EXIST )
    m = F_OK;
  else
  { if ( mode & ACCESS_READ    ) m |= R_OK;
    if ( mode & ACCESS_WRITE   ) m |= W_OK;
#ifdef X_OK
    if ( mode & ACCESS_EXECUTE ) m |= X_OK;
#endif
  }

  return m;
}

int
AccessFile(const char *path, int mode)
{ char tmp[PATH_MAX];
#ifdef HAVE_ACCESS
  return access(OsPath(path, tmp), access_mode(mode)) == 0 ? TRUE : FALSE;
#else
#error "No implementation for AccessFile()"
#endif
}

int
AccessDirectory(const char *path, int mode)
{
#if O_XOS
  char tmp[PATH_MAX];
  return _xos_access_dir(OsPath(path, tmp), access_mode(mode)) == 0 ? TRUE : FALSE;
#else
  return AccessFile(path, mode);
#endif
}


int
ExistsFile(const char *path)
{
#ifdef O_XOS
  return _xos_exists(path, _XOS_FILE) == TRUE;
#else
  char tmp[PATH_MAX];
  statstruct buf;

  if ( statfunc(OsPath(path, tmp), &buf) == -1 || !S_ISREG(buf.st_mode) )
  { DEBUG(2, perror(tmp));
    return FALSE;
  }
  return TRUE;
#endif
}


int
ExistsDirectory(const char *path)
{
#ifdef O_XOS
  return _xos_exists(path, _XOS_DIR) == TRUE;
#else
  char tmp[PATH_MAX];
  char *ospath = OsPath(path, tmp);
  statstruct buf;

  if ( statfunc(ospath, &buf) < 0 )
    return FALSE;

  if ( S_ISDIR(buf.st_mode) )
    return TRUE;

  return FALSE;
#endif /*O_XOS*/
}


static char *
ReadLink(const char *f, char *buf)
{
#ifdef HAVE_READLINK
  int n;

  if ( (n=readlink(f, buf, PATH_MAX-1)) > 0 )
  { buf[n] = EOS;
    return buf;
  }
#endif

  return NULL;
}


static char *
DeRefLink1(const char *f, char *lbuf, size_t buflen)
{ char buf[PATH_MAX];
  char *l;

  if ( (l=ReadLink(f, buf)) )
  { if ( l[0] == '/' )			/* absolute path */
    { strcpy(lbuf, buf);
      return lbuf;
    } else
    { char *q;

      if ( f != (const char*)lbuf )
	strcpy(lbuf, f);
      q = &lbuf[strlen(lbuf)];
      while(q>lbuf && q[-1] != '/')
	q--;
      strcpy(q, l);

      return canonicaliseFileName(lbuf, buflen);
    }
  }

  return NULL;
}


/** char *DeRefLink(const char *link, char *buf)

Dereference a symbolic  link,  returning   its  final  destination.  The
returned filename is canonical  (i.e.,  references   to  ./  and ../ are
removed). Returns NULL if more than 20 links have been followed.
*/

char *
DeRefLink(const	char *link, char *buf)
{ char tmp[PATH_MAX];
  char *f;
  int n = 20;				/* avoid loop! */

  while((f=DeRefLink1(link, tmp, sizeof(tmp))) && n-- > 0)
    link = f;
  if ( PL_exception(0) )		/* Name too long */
    return NULL;

  if ( n > 0 )
  { strcpy(buf, link);
    return buf;
  } else
  { GET_LD
    atom_t dom = PL_new_atom("dereference");
    atom_t typ = PL_new_atom("symlink");
    term_t t;
    int rc;

    rc = ( (t=PL_new_term_ref()) &&
	   PL_unify_chars(t, PL_ATOM|REP_FN, -1, link) &&
	   PL_error(NULL, 0, "too many (>20) levels of symbolic links",
		    ERR_PERMISSION, dom, typ, t) );
    (void)rc;
    PL_unregister_atom(dom);
    PL_unregister_atom(typ);

    return NULL;
  }
}


static int
SameFile(const char *f1, const char *f2)
{ GET_LD

  if ( truePrologFlag(PLFLAG_FILE_CASE) )
  { if ( streq(f1, f2) )
      return TRUE;
  } else
  { if ( strcasecmp(f1, f2) == 0 )
      return TRUE;
  }

#ifdef __unix__				/* doesn't work on most not Unix's */
  { statstruct buf1;
    statstruct buf2;
    char tmp[PATH_MAX];

    if ( statfunc(OsPath(f1, tmp), &buf1) != 0 ||
	 statfunc(OsPath(f2, tmp), &buf2) != 0 )
      return FALSE;
    if ( buf1.st_ino == buf2.st_ino && buf1.st_dev == buf2.st_dev )
      return TRUE;
  }
#endif
#ifdef O_XOS
  return _xos_same_file(f1, f2) == TRUE;
#endif /*O_XOS*/
    /* Amazing! There is no simple way to check two files for identity. */
    /* stat() and fstat() both return dummy values for inode and device. */
    /* this is fine as OS'es not supporting symbolic links don't need this */

  return FALSE;
}


/** int RemoveFile(const char *path)

Remove a file from the filesystem.  Returns   TRUE  on success and FALSE
otherwise.
*/

int
RemoveFile(const char *path)
{ char tmp[PATH_MAX];

#ifdef HAVE_REMOVE
  return remove(OsPath(path, tmp)) == 0 ? TRUE : FALSE;
#else
  return unlink(OsPath(path, tmp)) == 0 ? TRUE : FALSE;
#endif
}


static int
RenameFile(const char *old, const char *new)
{ char oldbuf[PATH_MAX];
  char newbuf[PATH_MAX];
  char *osold, *osnew;

  osold = OsPath(old, oldbuf);
  osnew = OsPath(new, newbuf);

#ifdef HAVE_RENAME
  return rename(osold, osnew) == 0 ? TRUE : FALSE;
#else
{ int rval;

  unlink(osnew);
  if ( (rval = link(osold, osnew)) == 0
       && (rval = unlink(osold)) != 0)
    unlink(osnew);

  if ( rval == 0 )
    return TRUE;

  return FALSE;
}
#endif /*HAVE_RENAME*/
}


static int
MarkExecutable(const char *name)
{
#if ( (defined(HAVE_STAT) && defined(HAVE_CHMOD)) || \
      defined(__unix__) ) && !defined(__WINDOWS__)
  statstruct buf;
  mode_t um;

  um = umask(0777);
  umask(um);
  if ( statfunc(name, &buf) == -1 )
  { GET_LD
    term_t file = PL_new_term_ref();

    PL_put_atom_chars(file, name);
    return PL_error(NULL, 0, MSG_ERRNO, ERR_FILE_OPERATION,
		    ATOM_stat, ATOM_file, file);
  }

  if ( (buf.st_mode & 0111) == (~um & 0111) )
    return TRUE;

  buf.st_mode |= 0111 & ~um;
  if ( chmod(name, buf.st_mode) == -1 )
  { GET_LD
    term_t file = PL_new_term_ref();

    PL_put_atom_chars(file, name);
    return PL_error(NULL, 0, MSG_ERRNO, ERR_FILE_OPERATION,
		    ATOM_chmod, ATOM_file, file);
  }
#endif /* defined(HAVE_STAT) && defined(HAVE_CHMOD) */

  return TRUE;
}


		/********************************
		*	FIND FILES FROM C       *
		*********************************/

int
unifyTime(term_t t, time_t time)
{ return PL_unify_time(t, time);
}


static int
add_option(term_t options, functor_t f, atom_t val)
{ GET_LD
  term_t head;

  if ( (head=PL_new_term_ref()) &&
       PL_unify_list(options, head, options) &&
       PL_unify_term(head, PL_FUNCTOR, f, PL_ATOM, val) )
  { PL_reset_term_refs(head);
    return TRUE;
  }

  return FALSE;
}

#define CVT_FILENAME (CVT_ATOM|CVT_STRING|CVT_LIST)

static int
get_file_name(term_t n, char **namep, char *tmp, size_t tmplen, int flags)
{ GET_LD
  char *name;
  int chflags;
  size_t len;

  if ( flags & PL_FILE_SEARCH )
  { fid_t fid;

    if ( (fid = PL_open_foreign_frame()) )
    { if ( !GD->procedures.absolute_file_name3 )
	GD->procedures.absolute_file_name3 =
	  PL_predicate("absolute_file_name", 3, "system");
      term_t av = PL_new_term_refs(3);
      term_t options = PL_copy_term_ref(av+2);
      int rc = TRUE;
      int cflags = ((flags&PL_FILE_NOERRORS) ? PL_Q_CATCH_EXCEPTION
					     : PL_Q_PASS_EXCEPTION);

      PL_put_term(av+0, n);

      if ( rc && flags & PL_FILE_EXIST )
	rc = add_option(options, FUNCTOR_access1, ATOM_exist);
      if ( rc && flags & PL_FILE_READ )
	rc = add_option(options, FUNCTOR_access1, ATOM_read);
      if ( rc && flags & PL_FILE_WRITE )
	rc = add_option(options, FUNCTOR_access1, ATOM_write);
      if ( rc && flags & PL_FILE_EXECUTE )
	rc = add_option(options, FUNCTOR_access1, ATOM_execute);

      if ( rc ) rc = PL_unify_nil(options);
      if ( rc ) rc = PL_call_predicate(NULL, cflags,
				       GD->procedures.absolute_file_name3, av);
      if ( rc ) rc = PL_get_nchars(av+1, &len, namep,
				   CVT_ATOMIC|BUF_STACK|REP_FN);
      if ( rc && strlen(*namep) != len )
      { n = av+1;
	goto code0;
      }

      PL_discard_foreign_frame(fid);
      return rc;
    }

    return FALSE;
  }

  chflags = CVT_FILENAME;
  if ( !(flags&(REP_UTF8|REP_MB)) )
    chflags |= REP_FN;
  if ( !(flags & PL_FILE_NOERRORS) )
    chflags |= CVT_EXCEPTION;
  if ( !PL_get_nchars(n, &len, &name, chflags) )
    return FALSE;
  if ( strlen(name) != len )
  { code0:
    return PL_error(NULL, 0, "file name contains a 0-code",
		    ERR_DOMAIN, ATOM_file_name, n);
  }
  if ( len >= PATH_MAX )
    return PL_error(NULL, 0, NULL, ERR_REPRESENTATION,
		    ATOM_max_path_length);

  if ( truePrologFlag(PLFLAG_FILEVARS) )
  { if ( !(name = expandVars(name, tmp, PATH_MAX)) )
      return FALSE;
  }

  if ( !(flags & PL_FILE_NOERRORS) )
  { atom_t op = 0;

    if ( (flags&(PL_FILE_READ|PL_FILE_WRITE|PL_FILE_EXECUTE|PL_FILE_EXIST)) &&
	 !AccessFile(name, ACCESS_EXIST) )
      return PL_error(NULL, 0, NULL, ERR_EXISTENCE, ATOM_file, n);

    if ( (flags&PL_FILE_READ) && !AccessFile(name, ACCESS_READ) )
      op = ATOM_read;
    if ( !op && (flags&PL_FILE_WRITE) && !AccessFile(name, ACCESS_WRITE) )
      op = ATOM_write;
    if ( !op && (flags&PL_FILE_EXECUTE) && !AccessFile(name, ACCESS_EXECUTE) )
      op = ATOM_execute;

    if ( op )
      return PL_error(NULL, 0, NULL, ERR_PERMISSION, op, ATOM_file, n);
  }

  if ( flags & PL_FILE_ABSOLUTE )
  { if ( !(name = AbsoluteFile(name, tmp, tmplen)) )
      return FALSE;
  }

  *namep = buffer_string(name, BUF_STACK);

  return TRUE;
}


int
PL_get_file_name(term_t n, char **namep, int flags)
{ char buf[PATH_MAX];
  char ospath[PATH_MAX];
  char *name;
  int rc;

  if ( (rc=get_file_name(n, &name, buf, sizeof(buf), flags)) )
  { if ( (flags & PL_FILE_OSPATH) )
    { if ( !(name = OsPath(name, ospath)) )
	return FALSE;
      name = buffer_string(name, BUF_STACK);
    }

    *namep = name;
  }

  return rc;
}


int
PL_get_file_nameW(term_t n, wchar_t **namep, int flags)
{ char buf[PATH_MAX];
  char ospath[PATH_MAX];
  char *name;
  int rc;

  if ( (rc=get_file_name(n, &name, buf, sizeof(buf), flags|REP_UTF8)) )
  { Buffer b;
    const char *s;

    if ( (flags & PL_FILE_OSPATH) )
    { if ( !(name = OsPath(name, ospath)) )
	return FALSE;
    }

    b = findBuffer(BUF_STACK);
    for(s = name; *s; )
    { int chr;

      PL_utf8_code_point(&s, NULL, &chr);
      addWcharBuffer(b, chr);
    }
    addWcharBuffer(b, 0);

    *namep = baseBuffer(b, wchar_t);
  }

  return rc;
}


		 /*******************************
		 *	   QUERY FILES		*
		 *******************************/

static
PRED_IMPL("time_file", 2, time_file, 0)
{ char *fn;

  if ( PL_get_file_name(A1, &fn, 0) )
  { double time;
    int sl;

    if ( (sl=file_name_is_iri(fn)) )
    { return ( iri_hook(fn, IRI_TIME, &time) &&
	       PL_unify_float(A2, time) );
    }

    if ( LastModifiedFile(fn, &time) )
      return PL_unify_float(A2, time);

    return PL_error(NULL, 0, NULL, ERR_FILE_OPERATION,
		    ATOM_time, ATOM_file, A1);
  }

  return FALSE;
}


static
PRED_IMPL("size_file", 2, size_file, 0)
{ PRED_LD
  char *n;

  if ( PL_get_file_name(A1, &n, 0) )
  { int64_t size;
    int sl;

    if ( (sl=file_name_is_iri(n)) )
    { return ( iri_hook(n, IRI_SIZE, &size) &&
	       PL_unify_int64(A2, size) );
    }

    if ( (size = SizeFile(n)) < 0 )
      return PL_error("size_file", 2, MSG_ERRNO, ERR_FILE_OPERATION,
		      ATOM_size, ATOM_file, A1);

    return PL_unify_int64(A2, size);
  }

  return FALSE;
}


static
PRED_IMPL("access_file", 2, access_file, 0)
{ PRED_LD
  char *n;
  int md;
  atom_t m;
  int sl;

  term_t name = A1;
  term_t mode = A2;

  if ( !PL_get_atom(mode, &m) )
    return PL_error("access_file", 2, NULL, ERR_TYPE, ATOM_atom, mode);
  if ( !PL_get_file_name(name, &n, 0) )
    return FALSE;

  if ( m == ATOM_none )
    return TRUE;

  if      ( m == ATOM_write || m == ATOM_append )
    md = ACCESS_WRITE;
  else if ( m == ATOM_read )
    md = ACCESS_READ;
  else if ( m == ATOM_execute || m == ATOM_search )
    md = ACCESS_EXECUTE;
  else if ( m == ATOM_exist )
    md = ACCESS_EXIST;
  else
    return PL_error("access_file", 2, NULL, ERR_DOMAIN, ATOM_io_mode, mode);

  if ( (sl=file_name_is_iri(n)) )
  { int rc;

    if ( !iri_hook(n, IRI_ACCESS, md, &rc) )
      return FALSE;

    return rc;
  }

  if ( AccessFile(n, md) )
    return TRUE;

  if ( md == ACCESS_WRITE && !AccessFile(n, ACCESS_EXIST) )
  { char tmp[PATH_MAX];
    char *dir;

    if ( !(dir = DirName(n, tmp)) )
      return PL_representation_error("max_path_length");
    if ( dir[0] )
    { if ( !ExistsDirectory(dir) )
	return FALSE;
    }
    if ( AccessDirectory(dir[0] ? dir : ".", md) )
      return TRUE;
  }

  return FALSE;
}


static
PRED_IMPL("read_link", 3, read_link, 0)
{ char *n, *l, *t;
  char buf[PATH_MAX];

  term_t file = A1;
  term_t link = A2;
  term_t to   = A3;

  if ( !PL_get_file_name(file, &n, 0) )
    return FALSE;

  if ( (l = ReadLink(n, buf)) &&
       PL_unify_chars(link, PL_ATOM|REP_FN, (size_t)-1, l) &&
       (t = DeRefLink(n, buf)) &&
       PL_unify_chars(to, PL_ATOM|REP_FN, (size_t)-1, t) )
    return TRUE;

  return FALSE;
}


static
PRED_IMPL("exists_file", 1, exists_file, 0)
{ char *n;
  int sl;

  if ( !PL_get_file_name(A1, &n, 0) )
    return FALSE;

  if ( (sl=file_name_is_iri(n)) )
  { int rc;

    if ( !iri_hook(n, IRI_ACCESS, ACCESS_FILE, &rc) )
      return FALSE;

    return rc;
  }

  return ExistsFile(n);
}


static
PRED_IMPL("exists_directory", 1, exists_directory, 0)
{ char *n;
  int sl;

  if ( !PL_get_file_name(A1, &n, 0) )
    return FALSE;

  if ( (sl=file_name_is_iri(n)) )
  { int rc;

    if ( !iri_hook(n, IRI_ACCESS, ACCESS_DIRECTORY, &rc) )
      return FALSE;

    return rc;
  }

  return ExistsDirectory(n);
}


static
PRED_IMPL("is_absolute_file_name", 1, is_absolute_file_name, 0)
{ char *n;

  if ( PL_get_file_name(A1, &n, 0) &&
       (IsAbsolutePath(n) || file_name_is_iri(n)) )
    return TRUE;

  return FALSE;
}


static
PRED_IMPL("same_file", 2, same_file, 0)
{ char *n1, *n2;

  if ( PL_get_file_name(A1, &n1, 0) &&
       PL_get_file_name(A2, &n2, 0) )
    return SameFile(n1, n2);

  return FALSE;
}


static
PRED_IMPL("file_base_name", 2, file_base_name, 0)
{ char *n, *b;
  char tmp[PATH_MAX];

  if ( !PL_get_chars(A1, &n, CVT_ALL|REP_FN|CVT_EXCEPTION) )
    return FALSE;

  if ( (b=BaseName(n, tmp)) )
    return PL_unify_chars(A2, PL_ATOM|REP_FN, -1, b);
  else
    return PL_representation_error("max_path_length");
}


static
PRED_IMPL("file_directory_name", 2, file_directory_name, 0)
{ char *n, *d;
  char tmp[PATH_MAX];

  if ( !PL_get_chars(A1, &n, CVT_ALL|REP_FN|CVT_EXCEPTION) )
    return FALSE;

  if ( (d=DirName(n, tmp)) )
    return PL_unify_chars(A2, PL_ATOM|REP_FN, -1, d);
  else
    return PL_representation_error("max_path_length");
}


		 /*******************************
		 *	  TEMPORARY FILES	*
		 *******************************/

static
PRED_IMPL("tmp_file", 2, tmp_file, 0)
{ PRED_LD
  char *n;
  atom_t fn;

  term_t base = A1;
  term_t name = A2;

  if ( !PL_get_chars(base, &n, CVT_ALL|CVT_EXCEPTION) )
    return FALSE;

  if ( (fn=TemporaryFile(n, "", NULL)) )
    return PL_unify_atom(name, fn);
  else
    return PL_error(NULL, 0, MSG_ERRNO, ERR_FILE_OPERATION,
		    ATOM_create, ATOM_temporary_file, A1);
}

/** tmp_file_stream(+Ext, +Encoding, -File, -Stream)
*/

static
PRED_IMPL("$tmp_file_stream", 4, tmp_file_stream, 0)
{ PRED_LD
  atom_t fn;
  int fd;
  IOENC enc;
  atom_t encoding;
  const char *mode;
  char *ext;

  if ( !PL_get_chars(A1, &ext, CVT_ATOM|CVT_STRING|CVT_EXCEPTION) ||
       !PL_get_atom_ex(A2, &encoding) )
    return FALSE;
  if ( (enc = PL_atom_to_encoding(encoding)) == ENC_UNKNOWN )
  { if ( encoding == ATOM_binary )
    { enc = ENC_OCTET;
      mode = "wb";
    } else
    { return PL_error(NULL, 0, NULL, ERR_DOMAIN, ATOM_encoding, A1);
    }
  } else
  { mode = "w";
  }

  if ( (fn=TemporaryFile("", ext, &fd)) )
  { IOSTREAM *s;

    if ( !PL_unify_atom(A3, fn) )
    { close(fd);
      return PL_error(NULL, 0, NULL, ERR_UNINSTANTIATION, 2, A2);
    }

    s = Sfdopen(fd, mode);
    Ssetenc(s, enc, NULL);
    return PL_unify_stream(A4, s);
  } else
  { return PL_error(NULL, 0, MSG_ERRNO, ERR_FILE_OPERATION,
		    ATOM_create, ATOM_temporary_file, A2);
  }
}



		 /*******************************
		 *	CHANGE FILESYSTEM	*
		 *******************************/


static
PRED_IMPL("delete_file", 1, delete_file, 0)
{ PRED_LD
  char *n;
  atom_t aname;

  if ( PL_get_atom(A1, &aname) &&
       DeleteTemporaryFile(aname) )
    return TRUE;

  if ( !PL_get_file_name(A1, &n, 0) )
    return FALSE;

  if ( RemoveFile(n) )
    return TRUE;

  return PL_error(NULL, 0, MSG_ERRNO, ERR_FILE_OPERATION,
		  ATOM_delete, ATOM_file, A1);
}


static
PRED_IMPL("delete_directory", 1, delete_directory, 0)
{ char *n;

  if ( !PL_get_file_name(A1, &n, 0) )
    return FALSE;

  if ( rmdir(n) == 0 )
    return TRUE;
  else
    return PL_error(NULL, 0, MSG_ERRNO, ERR_FILE_OPERATION,
		    ATOM_delete, ATOM_directory, A1);
}


static
PRED_IMPL("make_directory", 1, make_directory, 0)
{ char *n;

  if ( !PL_get_file_name(A1, &n, 0) )
    return FALSE;

  if ( mkdir(n, 0777) == 0 )
    return TRUE;
  else
    return PL_error(NULL, 0, MSG_ERRNO, ERR_FILE_OPERATION,
		    ATOM_create, ATOM_directory, A1);
}


static
PRED_IMPL("rename_file", 2, rename_file, 0)
{ PRED_LD
  char *o, *n;

  term_t old = A1;
  term_t new = A2;

  if ( PL_get_file_name(old, &o, 0) &&
       PL_get_file_name(new, &n, 0) )
  { if ( SameFile(o, n) )
    { if ( truePrologFlag(PLFLAG_FILEERRORS) )
	return PL_error("rename_file", 2, "same file", ERR_PERMISSION,
			ATOM_rename, ATOM_file, old);
      return FALSE;
    }

    if ( RenameFile(o, n) )
      return TRUE;

    if ( truePrologFlag(PLFLAG_FILEERRORS) )
      return PL_error("rename_file", 2, MSG_ERRNO, ERR_FILE_OPERATION,
		      ATOM_rename, ATOM_file, old);
    return FALSE;
  }

  return FALSE;
}


static
PRED_IMPL("$absolute_file_name", 2, absolute_file_name, 0)
{ char *n;
  char tmp[PATH_MAX];

  term_t name = A1;
  term_t expanded = A2;

  if ( PL_get_file_name(name, &n, 0) )
  { if ( (n = AbsoluteFile(n, tmp, sizeof(tmp))) )
      return PL_unify_chars(expanded, PL_ATOM|REP_FN, -1, n);
  }

  return FALSE;
}


static
PRED_IMPL("$cwd", 1, cwd, 0)
{ char buf[PATH_MAX];
  const char *wd;

  if ( !(wd = PL_cwd(buf, sizeof(buf))) )
    return FALSE;

  return PL_unify_chars(A1, PL_ATOM|REP_FN, (size_t)-1, wd);
}


static
PRED_IMPL("$chdir", 1, chdir, 0)
{ PRED_LD
  char *n;

  if ( PL_get_file_name(A1, &n, 0) )
  { if ( ChDir(n) )
      return TRUE;

    if ( truePrologFlag(PLFLAG_FILEERRORS) )
      return PL_error(NULL, 0, NULL, ERR_FILE_OPERATION,
		      ATOM_chdir, ATOM_directory, A1);
  }

  return FALSE;
}


static int
has_extension(const char *name, const char *ext)
{ GET_LD
  const char *s = name + strlen(name);

  if ( ext[0] == EOS )
    return TRUE;

  while(*s != '.' && *s != '/' && s > name)
    s--;
  if ( *s == '.' && s > name && s[-1] != '/' )
  { if ( ext[0] == '.' )
      ext++;
    if ( truePrologFlag(PLFLAG_FILE_CASE) )
      return strcmp(&s[1], ext) == 0;
    else
      return strcasecmp(&s[1], ext) == 0;
  }

  return FALSE;
}


static int
name_too_long(void)
{ return PL_error(NULL, 0, NULL, ERR_REPRESENTATION, ATOM_max_path_length);
}


static
PRED_IMPL("file_name_extension", 3, file_name_extension, 0)
{ PRED_LD
  char *b = NULL, *e = NULL, *f;
  char buf[PATH_MAX];

  term_t base = A1;
  term_t ext  = A2;
  term_t full = A3;

  if ( !PL_is_variable(full) )
  { if ( PL_get_chars(full, &f, CVT_ALL|CVT_EXCEPTION|REP_FN) )
    { char *s = f + strlen(f);		/* ?base, ?ext, +full */

      while(*s != '.' && *s != '/' && s > f)
	s--;
      if ( *s == '.' )
      { if ( PL_get_chars(ext, &e, CVT_ALL|REP_FN) )
	{ if ( e[0] == '.' )
	    e++;
	  if ( truePrologFlag(PLFLAG_FILE_CASE) )
	  { TRY(strcmp(&s[1], e) == 0);
	  } else
	  { TRY(strcasecmp(&s[1], e) == 0);
	  }
	} else
	{ TRY(PL_unify_chars(ext, PL_ATOM|REP_FN, -1, &s[1]));
	}

	return PL_unify_chars(base, PL_ATOM|REP_FN, s-f, f);
      }
      if ( PL_unify_atom_chars(ext, "") &&
	   PL_unify(full, base) )
	PL_succeed;
    }
    PL_fail;
  }

  if ( PL_get_chars(base, &b, CVT_ALL|BUF_STACK|REP_FN|CVT_EXCEPTION) &&
       PL_get_chars(ext, &e, CVT_ALL|REP_FN|CVT_EXCEPTION) )
  { char *s;

    if ( e[0] == '.' )		/* +Base, +Extension, -Full */
      e++;
    if ( has_extension(b, e) || e[0] == EOS )
      return PL_unify(base, full);
    if ( strlen(b) + 1 + strlen(e) + 1 > PATH_MAX )
      return name_too_long();
    strcpy(buf, b);
    s = buf + strlen(buf);
    *s++ = '.';
    strcpy(s, e);

    return PL_unify_chars(full, PL_ATOM|REP_FN, -1, buf);
  } else
    return FALSE;
}


static
PRED_IMPL("prolog_to_os_filename", 2, prolog_to_os_filename, 0)
{ PRED_LD

  term_t pl = A1;
  term_t os = A2;

#ifdef O_XOS
  wchar_t *wn;

  if ( !PL_is_variable(pl) )
  { char *n;
    char buf[PATH_MAX];

    if ( PL_get_chars(pl, &n, CVT_ALL|REP_UTF8|CVT_EXCEPTION) )
    { if ( !_xos_os_filename(n, buf, PATH_MAX) )
	return name_too_long();

      return PL_unify_chars(os, PL_ATOM|REP_UTF8, -1, buf);
    }
    return FALSE;
  }

  if ( PL_get_wchars(os, NULL, &wn, CVT_ALL) )
  { wchar_t lbuf[PATH_MAX];
    char buf[PATH_MAX];

    _xos_long_file_nameW(wn, lbuf, PATH_MAX);
    _xos_canonical_filenameW(lbuf, buf, PATH_MAX, 0);

    return PL_unify_chars(pl, PL_ATOM|REP_UTF8, -1, buf);
  }

  return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_atom, pl);
#else /*O_XOS*/
  return PL_unify(pl, os);
#endif /*O_XOS*/
}


static
PRED_IMPL("$mark_executable", 1, mark_executable, 0)
{ char *name;

  if ( !PL_get_file_name(A1, &name, 0) )
    return PL_error(NULL, 0, NULL, ERR_DOMAIN, ATOM_source_sink, A1);

  return MarkExecutable(name);
}

/**
 * '$my_file'(+Path) is semidet.
 *
 * True if Path exists and is owned by the same user as the current
 * process.  If the OS or filesystem doesn't support ownership the
 * result is true if Path exists.
 */

static
PRED_IMPL("$my_file", 1, my_file, 0)
{ char *n;

  if ( !PL_get_file_name(A1, &n, 0) ||
       file_name_is_iri(n) )
    return FALSE;

#ifdef HAVE_GETUID
{ statstruct buf;
  char tmp[PATH_MAX];

  if ( statfunc(OsPath(n, tmp), &buf) < 0 )
  { perror(tmp);
    return FALSE;
  }

  if ( buf.st_uid != getuid() )
    return FALSE;
}
#endif

  return TRUE;
}


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

BeginPredDefs(files)
  PRED_DEF("$cwd", 1, cwd, 0)
  PRED_DEF("$chdir", 1, chdir, 0)
  PRED_DEF("access_file", 2, access_file, 0)
  PRED_DEF("time_file", 2, time_file, 0)
  PRED_DEF("size_file", 2, size_file, 0)
  PRED_DEF("read_link", 3, read_link, 0)
  PRED_DEF("exists_file", 1, exists_file, 0)
  PRED_DEF("exists_directory", 1, exists_directory, 0)
  PRED_DEF("tmp_file", 2, tmp_file, 0)
  PRED_DEF("$tmp_file_stream", 4, tmp_file_stream, 0)
  PRED_DEF("delete_file", 1, delete_file, 0)
  PRED_DEF("delete_directory", 1, delete_directory, 0)
  PRED_DEF("make_directory", 1, make_directory, 0)
  PRED_DEF("same_file", 2, same_file, 0)
  PRED_DEF("rename_file", 2, rename_file, 0)
  PRED_DEF("is_absolute_file_name", 1, is_absolute_file_name, 0)
  PRED_DEF("file_base_name", 2, file_base_name, 0)
  PRED_DEF("file_directory_name", 2, file_directory_name, 0)
  PRED_DEF("file_name_extension", 3, file_name_extension, 0)
  PRED_DEF("prolog_to_os_filename", 2, prolog_to_os_filename, 0)
  PRED_DEF("$mark_executable", 1, mark_executable, 0)
  PRED_DEF("$absolute_file_name", 2, absolute_file_name, 0)
  PRED_DEF("$my_file", 1, my_file, 0)
EndPredDefs
