/* emxdep.c, emx-specific bits of GNU Emacs.
   Copyright (C) 1993, 1994 Eberhard Mattes.

This file is part of GNU Emacs.

GNU Emacs 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.

GNU Emacs 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 GNU Emacs; see the file COPYING.  If not, write to
the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.  */

#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <fcntl.h>
#include <sys/types.h>
#include <sys/process.h>
#include <sys/ea.h>
#include <sys/ead.h>

#define INCL_DEVICES
#define INCL_DOSPROCESS
#define INCL_DOSSESMGR
#define INCL_DOSERRORS
#define INCL_WINSWITCHLIST
#define INCL_KBD
#define INCL_VIO
#define UCHAR OS2UCHAR
#include <os2.h>
#undef UCHAR

#include "config.h"
#include "lisp.h"
#include "commands.h"

/* Priority class and level.  */
struct priority
{
  ULONG pclass;
  LONG plevel;
};

extern Lisp_Object Qicon;

Lisp_Object Qascii;
Lisp_Object Qbinary;
Lisp_Object Qbitmap;
Lisp_Object Qmetafile;
Lisp_Object Qea;
Lisp_Object Qmvmt;
Lisp_Object Qmvst;
Lisp_Object Qasn1;

/* Alist of elements (REGEXP . HANDLER) for program file names for
   which HANDLER is called by call-process and start-process.  */
static Lisp_Object Vprogram_name_handler_alist;

/* This variable describes handlers that have "already" had a chance
   to handle the current operation.  */
static Lisp_Object Vinhibit_program_name_handlers;

/* List of regular expressions identifying file names for which binary
   mode is to be used.  */
Lisp_Object Vemx_binary_mode_list;

/* The system emx is running on: `ms-dos' or `os2'.  */
Lisp_Object Vemx_system_type;

/* The priority to be used for child processes.  */
Lisp_Object Vprocess_priority;

/* Use binary mode for input pipe to processes and output pipe from
   processes, respectively.  */
int binary_process_input;
int binary_process_output;

/* The current code page.  */
int cur_code_page;

/* Process priority class and level to be used for child process, set
   by check_process_priority.  */
static struct priority child_priority;

/* Process priority class and level of the main thread of Emacs.  */
static struct priority emacs_priority;

/* The following variables are used for accessing text-mode files as
   if they were binary files.  fb_fd is the handle of the current
   `faked binary file' (there can be at most one such file at a time).
   If fb_bd is -1, there is no `faked binary file'.  fb_buf holds the
   complete contents of the file, with cr/lf translated to newline.
   fb_size is the number of translated bytes.  fb_pos is the current
   value of the file position indicator.  */
static int fb_fd;
static char *fb_buf;
static int fb_size;
static int fb_pos;

extern Lisp_Object Vprocess_environment;
extern int pm_pid;
extern int pm_session_started;
extern Lisp_Object pm_list_code_pages ();


int sigblock (int mask)
{
  return 0;
}

int sigsetmask (int mask)
{
  return 0;
}

int nice (int incr)
{
  return 0;
}

int setuid (int id)
{
  return 0;
}

int link (char *name1, char *name2)
{
  return (rename (name1, name2));
}

int setpgrp (int pid, int pgrp)
{
  return 0;
}

int gethostname (char *name, int namelen)
{
  char *sp = getenv ("SYSTEMNAME");
  if (!sp)
    sp = "standalone";
  _strncpy (name, sp, namelen);
  return 0;
}

int vfork (void)
{
  return 0;                     /* We're the child process! */
}


/* The following functions are used to be able to read a text-mode
   file as if it were a binary file, that is, lseek() works and the
   st_size field of struct stat is exact.  This is done by reading the
   entire file into memory, translating cr/lf to the newline
   character.  Only one file at a time can be a `faked binary file'.  */

/* Prepare for reading from FD as if it were the handle of a binary
   file.  SIZE is a pointer to the st_size field of struct stat for
   the file.  This function assumes that FD is opened in text mode.
   Return 0 on success, -1 on error.  */

int fb_start (int fd, off_t *size)
{
  if (fb_fd != -1)
    abort ();
  fb_fd = fd;
  fb_pos = 0;
  fb_buf = (char *) xmalloc (*size);
  fb_size = read (fd, fb_buf, *size);
  if (fb_size < 0)
    {
      xfree (fb_buf);
      fb_fd = -1;
      return -1;
    }
  *size = fb_size;
  return 0;
}


/* Replace read() for `faked binary files'.  If FD is not the handled
   passed to fb_start(), the original read() function is called.  */

int fb_read (int fd, void *buf, int nbyte)
{
  if (fd != fb_fd)
    return read (fd, buf, nbyte);
  if (nbyte > fb_size - fb_pos)
    nbyte = fb_size - fb_pos;
  bcopy (fb_buf + fb_pos, buf, nbyte);
  fb_pos += nbyte;
  return nbyte;
}


/* Replace lseek() for `faked binary files'.  If FD is not the handled
   passed to fb_start(), the original lseek() function is called.  */

long fb_lseek (int fd, long offset, int origin)
{
  if (fd != fb_fd)
    return lseek (fd, offset, origin);
  if (origin != SEEK_SET)
    abort ();
  if (offset < 0 || offset > fb_size)
    return (-1);
  fb_pos = offset;
  return fb_pos;
}


/* Replace close() for `faked binary files'.  If FD is not the handled
   passed to fb_start(), the original close() function is called.
   This function releases the memory allocated by fb_start() and
   removes the special meaning of FD for the functions above.  */

int fb_close (int fd)
{
  if (fd == fb_fd)
    {
      xfree (fb_buf);
      fb_fd = -1;
    }
  return close (fd);
}


#define UNC_P(s) (PATH_DELIM_P ((s)[0]) && PATH_DELIM_P ((s)[1]) && !PATH_DELIM_P ((s)[2]))

Lisp_Object emx_expand_file_name (const unsigned char *nm, Lisp_Object defalt)
{
  const unsigned char *p;
  unsigned char *q, *result;
  int trailing_slash, drive, size;

  /* Check for a trailing slash (which will be preserved).  */

  if (*nm == 0)
    trailing_slash = 0;
  else
    {
      p = strchr (nm, 0);
      trailing_slash = PATH_DELIM_P (p[-1]);
    }
  p = nm;

  /* Expand "~" and "~user".  */

  if (p[0] == '~')
    {
      unsigned char *tem;

      ++p;
      while (*p != 0 && !PATH_DELIM_P (*p))
	++p;			/* skip user name ("all users are equal") */
      if (*p != 0)
	++p;			/* skip slash or backslash */
      q = (unsigned char *) egetenv ("HOME");
      if (q == 0 || *q == 0)
        {
          /* HOME not set, use the root directory of the current
             drive.  */

          tem = alloca (strlen (p) + 2);
          tem[0] = '/';
          strcpy (tem + 1, p);
        }
      else
        {
          tem = alloca (strlen (q) + strlen (p) + 2);
          strcpy (tem, q);
          q = strchr (tem, 0);
          while (q != tem && PATH_DELIM_P (q[-1]))
            --q;
          *q++ = '/';
          strcpy (q, p);
        }
      p = tem;
    }

  if (!_fngetdrive (p) && !UNC_P (p))
    {
      /* There is no drive letter.  Get the drive letter (or the
         complete directory) from the default directory.  */

      unsigned char *tem;

      CHECK_STRING (defalt, 1);
      q = XSTRING (defalt)->data;
      if (PATH_DELIM_P (*p))
        {
          /* It's an absolute pathname lacking a drive letter.
             Prepend the drive letter of the default directory.  */

          drive = _fngetdrive (q);
          if (drive)
            {
              while (PATH_DELIM_P (*p))
                ++p;
              tem = alloca (strlen (p) + 4);
              tem[0] = (unsigned char)drive;
              tem[1] = ':';
              tem[2] = '/';
              strcpy (tem + 3, p);
              p = tem;
            }
        }
      else
        {
          /* It's a relative pathname.  Prepend the default directory.  */

          tem = alloca (strlen (q) + strlen (p) + 2);
          strcpy (tem, q);
          q = strchr (tem, 0);
          if (q != tem && !PATH_DELIM_P (q[-1]))
            *q++ = '/';
          strcpy (q, p);
          p = tem;
        }
    }

  /* Prepend the drive letter (and a slash if there's no slash after
     the drive letter -- a drive letter always denotes the root
     directory).  */

  drive = _fngetdrive (p);
  if (drive)
    p += 2;
  else if (UNC_P (p))
    {
      /* Universal Naming Convention (\\server\path) -- don't prepend
         a drive letter.  */
      drive = -1;
    }
  else
    drive = _getdrive ();

  if (drive != -1)
    {
      unsigned char *tem;

      while (PATH_DELIM_P (*p))
        ++p;
      tem = alloca (strlen (p) + 4);
      tem[0] = (unsigned char)drive;
      tem[1] = ':';
      tem[2] = '/';
      strcpy (tem + 3, p);
      p = tem;
    }

  /* Now remove "/./" and "/../".  As we've created an absolute
     pathname, the output string of _abspath() is not longer than the
     input string.  _abspath() translates backslashes into forward
     slashes.  */

  size = strlen (p) + 1;
  result = alloca (size + 1);   /* One extra byte for the trailing slash */
  if (_abspath (result, p, size) != 0)
    error ("Internal error in expand-file-name");

  /* Add or remove the trailing slash.  */

  q = strchr (result, 0);
  if (q != result && PATH_DELIM_P (q[-1]))
    {
      if (!trailing_slash && !(_fngetdrive (result) && q == result + 3))
        q[-1] = 0;              /* Remove the trailing slash */
    }
  else if (trailing_slash)
    {
      q[0] = '/'; q[1] = 0;     /* Add a trailing slash */
    }

  /* Translate to lower case and build a Lisp string.  */

  _nls_strlwr (result);
  return build_string (result);
}


Lisp_Object find_program_name_handler (Lisp_Object filename)
{
  /* This function must not munge the match data.  */
  Lisp_Object chain;
  char *tem, *p;

  CHECK_STRING (filename, 0);

  /* Use a shortcut.  */

  if (NILP (Vprogram_name_handler_alist))
    return Qnil;

  /* Convert the string to lower case and replace backslashes with
     forward slashes.  This simplifies the regexps considerably.  */

  tem = (char *)alloca (XSTRING (filename)->size + 1);
  strcpy (tem, XSTRING (filename)->data);
  _nls_strlwr (tem);
  for (p = tem; *p != 0; ++p)
    if (*p == '\\')
      *p = '/';
  filename = build_string (tem);

  for (chain = Vprogram_name_handler_alist; XTYPE (chain) == Lisp_Cons;
       chain = XCONS (chain)->cdr)
    {
      Lisp_Object elt;
      elt = XCONS (chain)->car;
      if (XTYPE (elt) == Lisp_Cons)
	{
	  Lisp_Object string;
	  string = XCONS (elt)->car;
	  if (XTYPE (string) == Lisp_String
	      && fast_string_match (string, filename) >= 0
              && NILP (Fmemq (XCONS (elt)->cdr,
                              Vinhibit_program_name_handlers)))
            return XCONS (elt)->cdr;
	}
      QUIT;
    }
  return Qnil;
}


/* Set the priority of process or thread ID (depending on SCOPE) to
   the values found in PRTY.  */

static void set_priority (const struct priority *prty, ULONG scope, ULONG id)
{
  if (_osmode == OS2_MODE)
    {
      DosSetPriority (scope, prty->pclass, -31, id);
      if (prty->plevel != 0)
        DosSetPriority (scope, prty->pclass, prty->plevel, id);
    }
}


/* Decode the priority class and level given by PCLASS and PLEVEL,
   respectively.  Store the result to *PRTY.  Signal an error if input
   is invalid.  */

static void decode_priority (struct priority *prty, Lisp_Object pclass,
                             Lisp_Object plevel)
{
  if (NILP (pclass))
    prty->pclass = PRTYC_NOCHANGE;
  else if (EQ (pclass, intern ("idle-time")))
    prty->pclass = PRTYC_IDLETIME;
  else if (EQ (pclass, intern ("regular")))
    prty->pclass = PRTYC_REGULAR;
  else if (EQ (pclass, intern ("foreground-server")))
    prty->pclass = PRTYC_FOREGROUNDSERVER;
  else
    error ("Invalid priority class");
  if (NILP (plevel))
    prty->plevel = 0;
  else
    {
      CHECK_NUMBER (plevel, 1);
      prty->plevel = XINT (plevel);
      if (prty->plevel < 0 || prty->plevel > 31)
        error ("Invalid priority level");
    }
}


/* Check the value of process-priority and store the priority in
   child_priority.  This is done before starting the process as
   signalling an error after successfully starting the child process
   isn't a good idea.  */

void check_process_priority (void)
{
  if (CONSP (Vprocess_priority))
    decode_priority (&child_priority, Fcar (Vprocess_priority),
                     Fcdr (Vprocess_priority));
  else
    decode_priority (&child_priority, Vprocess_priority, Qnil);
}


/* Stolen from child_setup of callproc.c and hacked severly.  */

int emx_child_setup (in, out, err, new_argv, set_pgrp, current_dir)
     int in, out, err;
     register char **new_argv;
     int set_pgrp;
     Lisp_Object current_dir;
{
  int saved_in, saved_out, saved_err;
  char *org_cwd = 0;
  char org_cwd_buf[512];
  char **env, *p;
  int pid;

  {
    register unsigned char *temp;
    register int i;

    i = XSTRING (current_dir)->size;
    temp = (unsigned char *) alloca (i + 2);
    bcopy (XSTRING (current_dir)->data, temp, i);
    if (i > 1 && PATH_DELIM_P (temp[i-1]) && temp[i-2] != ':')
      --i;
    temp[i] = 0;
    org_cwd = _getcwd2 (org_cwd_buf, sizeof (org_cwd_buf));
    _chdir2 (temp);
  }

  /* Set `env' to a vector of the strings in Vprocess_environment.  */
  {
    register Lisp_Object tem;
    register char **new_env;
    register int new_length;

    new_length = 0;
    for (tem = Vprocess_environment;
	 (XTYPE (tem) == Lisp_Cons
	  && XTYPE (XCONS (tem)->car) == Lisp_String);
	 tem = XCONS (tem)->cdr)
      new_length++;

    /* new_length + 1 to include terminating 0 */
    env = new_env = (char **) alloca ((new_length + 1) * sizeof (char *));

    /* Copy the Vprocess_alist strings into new_env.  */
    for (tem = Vprocess_environment;
	 (XTYPE (tem) == Lisp_Cons
	  && XTYPE (XCONS (tem)->car) == Lisp_String);
	 tem = XCONS (tem)->cdr)
      *new_env++ = (char *) XSTRING (XCONS (tem)->car)->data;
    *new_env = 0;
  }

  saved_in = dup (0);
  saved_out = dup (1);
  saved_err = dup (2);

  if (saved_in == -1 || saved_out == -1 || saved_err == -1)
    {
      if (saved_in != -1) close (saved_in);
      if (saved_out != -1) close (saved_out);
      if (saved_err != -1) close (saved_err);
      return -1;
    }

  fcntl (saved_in, F_SETFD, 1);
  fcntl (saved_out, F_SETFD, 1);
  fcntl (saved_err, F_SETFD, 1);

  close (0);
  close (1);
  close (2);

  dup2 (in, 0);
  dup2 (out, 1);
  dup2 (err, 2);

  /* Close Emacs's descriptors that this process should not have.  */
  close_process_descs ();

  /* Set the priority.  Note that check_process_priority must have
     been called.  Changing the priority after starting the process
     yields ERROR_NOT_DESCENDANT, therefore we let the child process
     inherit the priority.  */
  if (!NILP (Vprocess_priority))
    set_priority (&child_priority, PRTYS_THREAD, 0);

  pid = spawnvpe (P_SESSION | P_MINIMIZE | P_BACKGROUND,
                  new_argv[0], (const char * const *)new_argv,
                  (const char * const *)env);

  /* Restore our priority.  */
  if (!NILP (Vprocess_priority))
    set_priority (&emacs_priority, PRTYS_THREAD, 0);

  dup2 (saved_in, 0); close (saved_in);
  dup2 (saved_out, 1); close (saved_out);
  dup2 (saved_err, 2); close (saved_err);
  if (org_cwd != 0)
    _chdir2 (org_cwd);
  return pid;
}


void emx_proc_input_pipe (int fd)
{
  if (fd >= 0 && binary_process_input)
    setmode (fd, O_BINARY);
}


void emx_proc_output_pipe (int fd)
{
  if (fd >= 0 && binary_process_output)
    setmode (fd, O_BINARY);
}


void emx_exec_name (char **dst)
{
  PTIB ptib;
  PPIB ppib;
  char name[280], *p;

  if (_osmode == OS2_MODE)
    {
      DosGetInfoBlocks (&ptib, &ppib);
      DosQueryModuleName (ppib->pib_hmte, sizeof (name), name);
      _nls_strlwr (name);
      *dst = strdup (name);
    }
  for (p = *dst; *p != 0; ++p)
    if (*p == '\\')
      *p = '/';
}


DEFUN ("emx-binary-mode-p", Femx_binary_mode_p, Semx_binary_mode_p, 1, 1, 0,
  "Return t if binary mode should be used for FILENAME.\n\
Otherwise, return nil.\n\
Binary mode is used if one of the regular expressions in\n\
`emx-binary-mode-list' match FILENAME.")
  (filename)
    Lisp_Object filename;
{
  /* This function must not munge the match data.  */
  Lisp_Object chain;

  CHECK_STRING (filename, 0);

  for (chain = Vemx_binary_mode_list; XTYPE (chain) == Lisp_Cons;
       chain = XCONS (chain)->cdr)
    {
      Lisp_Object elt;
      elt = XCONS (chain)->car;
      if (XTYPE (elt) == Lisp_String && fast_string_match (elt, filename) >= 0)
        return Qt;
      QUIT;
    }
  return Qnil;
}


DEFUN ("pm-session-bond", Fpm_session_bond, Spm_session_bond, 1, 1, 0,
  "Establish or break bond between emacs.exe and pmemacs.exe sessions.\n\
Non-nil BOND establishes the bond, nil BOND breaks the bond.")
  (bond)
     Lisp_Object bond;
{
  HSWITCH hSwitch;
  SWCNTRL data;
  STATUSDATA status;

  if (!pm_session_started)
    error ("PM Emacs connection not established");

  hSwitch = WinQuerySwitchHandle (NULLHANDLE, pm_pid);
  status.Length = sizeof (status);
  status.SelectInd = SET_SESSION_UNCHANGED;
  status.BondInd = (NILP (bond) ? SET_SESSION_NO_BOND : SET_SESSION_BOND);
  if (hSwitch != NULLHANDLE && WinQuerySwitchEntry (hSwitch, &data) == 0)
    DosSetSession (data.idSession, &status);
  return Qnil;
}


DEFUN ("remove-from-window-list", Fremove_from_window_list,
  Sremove_from_window_list, 0, 0, 0,
  "Remove Emacs from the Window List.")
  ()
{
  HSWITCH hSwitch;

  hSwitch = WinQuerySwitchHandle (NULLHANDLE, getpid ());
  WinRemoveSwitchEntry (hSwitch);
  return Qnil;
}


DEFUN ("filesystem-type", Ffilesystem_type, Sfilesystem_type,
  1, 1, 0,
  "Return a string identifying the filesystem type of PATH.\n\
Filesystem types include FAT, HPFS, LAN, CDFS, NFS and NETWARE.")
  (string)
     Lisp_Object string;
{
  char drive[3], type[16];
  int d;

  CHECK_STRING (string, 0);
  d = _fngetdrive (XSTRING (string)->data);
  if (d == 0)
    d = _getdrive ();
  drive[0] = (char)d;
  drive[1] = ':';
  drive[2] = 0;
  if (_filesys (drive, type, sizeof (type)) != 0)
    error ("_filesys() failed");
  return build_string (type);
}


DEFUN ("file-name-valid-p", Ffile_name_valid_p, Sfile_name_valid_p,
  1, 1, 0,
  "Return t if STRING is a valid file name.\n\
Whether a file name is valid or not depends on the file system.\n\
This is a special feature of GNU Emacs for emx.")
  (string)
     Lisp_Object string;
{
  int i;
  unsigned char *name;

  CHECK_STRING (string, 0);
  name = XSTRING (string)->data;
  if (_osmode == OS2_MODE)
    {
      i = open (name, O_RDONLY);
      if (i >= 0)
        {
          close (i);
          return Qt;
        }
      i = _syserrno ();
      return (i != 15 && i != 123 && i != 206) ? Qt : Qnil;
    }
  else
    {
      if (_fngetdrive (name) != 0)
        name += 2;
      if (*name == 0)
        return Qnil;
      if (strpbrk (name, " \"'*+,:;<=>?[]|") != NULL)
        return Qnil;
      for (i = 0; name[i] != 0; ++i)
        if (name[i] < 0x20)
          return Qnil;
      for (;;)
        {
          i = 0;
          while (*name != 0 && !PATH_DELIM_P (*name) && *name != '.')
            ++i, ++name;
          if (i > 8)
            return Qnil;
          if (*name == '.')
            {
              ++name;
              if (i == 0)
                {
                  if (*name == '.')
                    ++name;
                  if (*name != 0 && !PATH_DELIM_P (*name))
                    return Qnil;
                }
              i = 0;
              while (*name != 0 && !PATH_DELIM_P (*name) && *name != '.')
                ++i, ++name;
              if (i > 3)
                return Qnil;
            }
          if (*name == 0)
            return Qt;
          if (!PATH_DELIM_P (*name))
            return Qnil;
          ++name;
        }
    }
}


DEFUN ("keyboard-type", Fkeyboard_type, Skeyboard_type,
  0, 0, 0,
  "Return information about the keyboard.\n\
The value is a list of the form (COUNTRY SUBCOUNTRY CODEPAGE), where\n\
  COUNTRY is the country code of the keyboard layout (a string),\n\
    for instance \"US\".\n\
  SUBCOUNTRY is the subcountry code (a string), for instance \"103 \".\n\
  CODEPAGE is the codepage (a number), on which the current keyboard\n\
    translation table is based, for instance 437.\n\
This function is currently implemented under OS/2 only.\n\
If the keyboard information cannot be retrieved (because Emacs is\n\
running under MS-DOS, for instance), nil is returned.")
  ()
{
  ULONG plen, dlen, action;
  HFILE handle;
  struct
    {
      USHORT length;
      USHORT codepage;
      UCHAR strings[8];
    } kd;
  Lisp_Object value;

  value = Qnil;
  if (_osmode == OS2_MODE
      && DosOpen ("KBD$", &handle, &action, 0, 0,
                  OPEN_ACTION_FAIL_IF_NEW | OPEN_ACTION_OPEN_IF_EXISTS,
                  OPEN_ACCESS_READONLY | OPEN_SHARE_DENYNONE,
                  NULL) == 0)
    {
      kd.length = sizeof (kd);
      dlen = sizeof (kd); plen = 0;
      if (DosDevIOCtl (handle, 4, 0x7b, NULL, plen, &plen,
                       &kd, dlen, &dlen) == 0)
        value = Fcons (build_string (kd.strings),
                       Fcons (build_string (strchr (kd.strings, 0) + 1),
                              Fcons (make_number (kd.codepage), Qnil)));
      DosClose (handle);
    }
  return value;
}


DEFUN ("emacs-priority", Femacs_priority, Semacs_priority,
  1, 2, 0,
  "Set the priority of the Emacs process.\n\
PCLASS selects the priority class.  Possible values are\n\
  nil (no change),\n\
  idle-time (idle-time priority class -- you don't want to use this),\n\
  regular (regular priority class -- this is the OS/2 default,\n\
    a priority boost is applied if the process is in the foreground), and\n\
  foreground-server (fixed-high priority class -- use with care).\n\
PLEVEL is nil (same as 0) or a number between 0 and 31 which indicates\n\
  the priority level within the priority class.  Level 31 has the highest\n\
  priority in each class, the default value assigned by OS/2 is 0.\n\
Child processes inherit the priority unless process-priority is non-nil.\n\
This function is implemented under OS/2 only.")
  (pclass, plevel)
     Lisp_Object pclass, plevel;
{
  struct priority prty;

  decode_priority (&prty, pclass, plevel);
  set_priority (&prty, PRTYS_THREAD, 0);
  emacs_priority = prty;
  return Qnil;
}


/* This function is called on program startup.  */

void emx_setup (void)
{
  /* No `faked binary file' is currently in used.  */

  fb_fd = -1;

  /* Initialize the priority to be used after starting a child
     process.  At the moment, I'm too lazy for looking in TIB2...  */

  emacs_priority.pclass = PRTYC_REGULAR;
  emacs_priority.plevel = 0;

  /* Initialize the current code page.  */

  cur_code_page = 0;
  if (_osmode == OS2_MODE)
    {
      ULONG rc, cp, len;

      len = 0;
      rc = DosQueryCp (sizeof (cp), &cp, &len);
      if ((rc == 0 || rc == ERROR_CPLIST_TOO_SMALL) && len == sizeof (cp))
        cur_code_page = cp;
    }
}


DEFUN ("current-code-page", Fcurrent_code_page, Scurrent_code_page, 0, 0, 0,
  "Return the current code page identifier.\n\
The value is nil if the code page identifier cannot be retrieved.\n\
Code pages are not yet supported under MS-DOS.")
  ()
{
  if (_osmode == DOS_MODE || cur_code_page == 0)
    return Qnil;
  return make_number (cur_code_page);
}


DEFUN ("list-code-pages", Flist_code_pages, Slist_code_pages, 0, 0, 0,
  "Return a list of available code pages.\n\
Code pages are not yet supported under MS-DOS.")
  ()
{
  ULONG rc, acp[8], len;
  Lisp_Object list;
  int i;

  if (_osmode == DOS_MODE)
    return Qnil;
  if (pm_session_started)
    return pm_list_code_pages ();
  len = 0;
  rc = DosQueryCp (sizeof (acp), acp, &len);
  if ((rc != 0 && rc != ERROR_CPLIST_TOO_SMALL) || len < sizeof (acp[0]))
    return Qnil;
  list = Qnil;
  for (i = len / sizeof (acp[0]) - 1; i >= 1; --i)
    list = Fcons (make_number (acp[i]), list);
  return list;
}


DEFUN ("set-code-page", Fset_code_page, Sset_code_page, 1, 1, "NCode page: ",
  "Set the code page to CODE-PAGE.\n\
Code pages are not yet supported under MS-DOS.")
  (code_page)
     Lisp_Object code_page;
{
  CHECK_NUMBER (code_page, 0);
  if (_osmode == DOS_MODE)
    error ("Cannot set code page under MS-DOS");
  if (XINT (code_page) >= 1 && XINT (code_page) <= 32767)
    {
      USHORT rc, cp;

      cp = XINT (code_page);
      if (cp == cur_code_page)
        return Qnil;
      if (pm_session_started)
        {
          if (pm_set_code_page (cp))
            {
              cur_code_page = cp;
              return Qnil;
            }
        }
      else
        {
          rc = VioSetCp (0, cp, 0);
          if (rc == 0)
            {
              rc = KbdSetCp (0, cp, 0);
              if (rc != 0)
                VioSetCp (0, (USHORT)cur_code_page, 0);
            }
          if (rc == 0)
            {
              cur_code_page = cp;
              return Qnil;
            }
        }
    }
  error ("Invalid code page");
}


static Lisp_Object ea_to_lisp (struct _ea *pea)
{
  Lisp_Object elts[4];
  USHORT type, size;

  if (!pea->value)
    return Qnil;

  elts[0] = make_number (pea->flags);
  if (pea->size < 4)
    elts[1] = elts[2] = Qnil;
  else
    {
      type = ((USHORT *)pea->value)[0];
      size = ((USHORT *)pea->value)[1];
      switch (type)
        {
        case EAT_ASCII:
          elts[1] = Qascii;
          break;
        case EAT_BINARY:
          elts[1] = Qbinary;
          break;
        case EAT_BITMAP:
          elts[1] = Qbitmap;
          break;
        case EAT_METAFILE:
          elts[1] = Qmetafile;
          break;
        case EAT_ICON:
          elts[1] = Qicon;
          break;
        case EAT_EA:
          elts[1] = Qea;
          break;
        case EAT_MVMT:
          elts[1] = Qmvmt;
          break;
        case EAT_MVST:
          elts[1] = Qmvst;
          break;
        case EAT_ASN1:
          elts[1] = Qasn1;
          break;
        default:
          elts[1] = make_number (type);
          break;
        }
      elts[2] = make_number (size);
    }
  elts[3] = make_string (pea->value, pea->size);
  return Fvector (4, elts);
}


static void ea_from_lisp (struct _ea *pea, Lisp_Object vec)
{
  Lisp_Object l_flags, l_type, l_size, l_value;
  int value_size;
  void *value;

  if (XVECTOR (vec)->size != 4)
    error ("EA vector does not have 4 elements");

  l_flags = XVECTOR (vec)->contents[0];
  l_type  = XVECTOR (vec)->contents[1];
  l_size  = XVECTOR (vec)->contents[2];
  l_value = XVECTOR (vec)->contents[3];

  if (XTYPE (l_value) != Lisp_String)
    error ("Invalid EA vector");
  value_size = XSTRING (l_value)->size;
  value = alloca (value_size);
  bcopy (XSTRING (l_value)->data, value, value_size);

  if (XTYPE (l_flags) != Lisp_Int
      || XINT (l_flags) < 0 || XINT (l_flags > 255))
    error ("Invalid EA vector");
  pea->flags = XINT (l_flags);

  if (!NILP (l_type))
    {
      USHORT type;

      if (XTYPE (l_type) == Lisp_Int)
        {
          if (XINT (l_type) < 0 || XINT (l_type) > 65535)
            error ("Invalid EA vector");
          type = XINT (l_type);
        }
      else if (EQ (l_type, Qascii))
        type = EAT_ASCII;
      else if (EQ (l_type, Qbinary))
        type = EAT_BINARY;
      else if (EQ (l_type, Qbitmap))
        type = EAT_BITMAP;
      else if (EQ (l_type, Qmetafile))
        type = EAT_METAFILE;
      else if (EQ (l_type, Qicon))
        type = EAT_ICON;
      else if (EQ (l_type, Qea))
        type = EAT_EA;
      else if (EQ (l_type, Qmvmt))
        type = EAT_MVMT;
      else if (EQ (l_type, Qmvst))
        type = EAT_MVST;
      else if (EQ (l_type, Qasn1))
        type = EAT_ASN1;
      else
        error ("Invalid EA vector");
      if (value_size >= 4)
        ((USHORT *)value)[0] = type;
    }

  if (!NILP (l_size))
    {
      if (XTYPE (l_size) != Lisp_Int
          || XINT (l_size) < 0 || XINT (l_size > 65535 - 4))
        error ("Invalid EA vector");
      if (value_size >= 4)
        ((USHORT *)value)[1] = (USHORT)XINT (l_size);
    }
  pea->size = value_size;
  pea->value = xmalloc (value_size);
  bcopy (value, pea->value, value_size);
}


static Lisp_Object
ead_unwind (obj)
     Lisp_Object obj;
{
  _ead ead;
  char *s;

  s = XSTRING (obj)->data;
  /* When using emx 0.8h, this requires the C library of emxfix07.  */
  sscanf (s, "%p", &ead);
  _ead_destroy (ead);
  return Qnil;
}


static void ead_record_unwind_protect (_ead ead)
{
  char buf[64];

  /* _ead is a pointer type.  Make a string from its value to turn it
     into a Lisp object.  I don't dare to use XPNTR et al.  */
  sprintf (buf, "%p", ead);
  record_unwind_protect (ead_unwind, build_string (buf));
}


DEFUN ("get-ea", Fget_ea, Sget_ea, 2, 2, 0,
  "Get from file or directory PATH the extended attribute NAME.\n\
Return nil if there is no such extended attribute.  Otherwise,\n\
return a vector [FLAGS TYPE SIZE VALUE], where FLAGS is the flags byte\n\
of the extended attribute, TYPE identifies the type of the extended\n\
attribute (`ascii', `binary', `bitmap', `metafile', `icon', `ea',\n\
`mvmt', `mvst', `asn1', or a number), SIZE is the contents of the\n\
size field of the value and VALUE is the (binary) value\n\
of the extended attribute, including the type and size fields.\n\
TYPE and SIZE are nil if the value is too short.")
  (path, name)
     Lisp_Object path, name;
{
  struct _ea ea;
  Lisp_Object result;

  CHECK_STRING (path, 0);
  CHECK_STRING (name, 1);

  if (_ea_get (&ea, XSTRING (path)->data, 0, XSTRING (name)->data) != 0)
    report_file_error ("Getting extended attribute", Fcons (path, Qnil));
  result = ea_to_lisp (&ea);
  _ea_free (&ea);
  return result;
}


DEFUN ("get-ea-string", Fget_ea_string, Sget_ea_string, 2, 2, 0,
  "Get from file or directory PATH the extended attribute NAME.\n\
Return nil if there is no such extended attribute, or if the value\n\
of the extended attribute is not a string.")
  (path, name)
     Lisp_Object path, name;
{
  struct _ea ea;
  Lisp_Object result;

  CHECK_STRING (path, 0);
  CHECK_STRING (name, 1);

  if (_ea_get (&ea, XSTRING (path)->data, 0, XSTRING (name)->data) != 0)
    report_file_error ("Getting extended attribute", Fcons (path, Qnil));
  if (ea.value && ea.size >= 4 && *(USHORT *)ea.value == EAT_ASCII)
    result = make_string (ea.value + 4, ea.size - 4);
  else
    result = Qnil;
  _ea_free (&ea);
  return result;
}


DEFUN ("get-ea-list", Fget_ea_list, Sget_ea_list, 1, 1, 0,
  "Get from file or directory PATH all extended attributes.\n\
Return a list of elements (NAME . VECTOR), one element for each\n\
extended attribute.  NAME is the name of the extended attribute,\n\
VECTOR is a vector [FLAGS TYPE SIZE VALUE], where FLAGS is the flags\n\
byte of the extended attribute, TYPE identifies the type of the extended\n\
attribute (`ascii', `binary', `bitmap', `metafile', `icon', `ea',\n\
`mvmt', `mvst', `asn1', or a number), SIZE is the contents of the\n\
size field of the value and VALUE is the (binary) value\n\
of the extended attribute, including the type and size fields.\n\
TYPE and SIZE are nil if the value is too short.")
  (path)
     Lisp_Object path;
{
  _ead ead;
  struct _ea ea;
  Lisp_Object result, vec, name;
  int i, n;
  int count = specpdl_ptr - specpdl;

  CHECK_STRING (path, 0);

  ead = _ead_create ();
  if (!ead)
    report_file_error ("Getting extended attribute", Fcons (path, Qnil));

  ead_record_unwind_protect (ead);

  if (_ead_read (ead, XSTRING (path)->data, 0, 0) != 0)
    report_file_error ("Getting extended attribute", Fcons (path, Qnil));

  result = Qnil;
  n = _ead_count (ead);
  for (i = n; i >= 1; --i)
    {
      ea.flags = _ead_get_flags (ead, i);
      ea.size = _ead_value_size (ead, i);
      ea.value = (void *)_ead_get_value (ead, i);
      vec = ea_to_lisp (&ea);
      name = build_string (_ead_get_name (ead, i));
      result = Fcons (Fcons (name, vec), result);
    }

  return unbind_to (count, result);
}


DEFUN ("put-ea", Fput_ea, Sput_ea, 3, 3, 0,
  "Attach an extended attribute to the file or directory PATH.\n\
NAME is the name of the extended attribute.  DATA is a vector\n\
[FLAGS TYPE SIZE VALUE] containing the value, where FLAGS is the\n\
flags byte of the extended attribute, TYPE identifies the type of\n\
the extended attribute (`ascii', `binary', `bitmap', `metafile',\n\
`icon', `ea', `mvmt', `mvst', `asn1', or a number), SIZE is the\n\
size the value and VALUE is the (binary) value of the extended\n\
attribute, including the type and size fields.  If TYPE is non-nil,\n\
it will override the type field of VALUE.  If SIZE is non-nil, it\n\
will override the size field of VALUE.")
  (path, name, value)
     Lisp_Object path, name, value;
{
  struct _ea ea;

  CHECK_STRING (path, 0);
  CHECK_STRING (name, 1);
  CHECK_VECTOR (value, 2);

  ea_from_lisp (&ea, value);
  if (_ea_put (&ea, XSTRING (path)->data, 0, XSTRING (name)->data) != 0)
    {
      xfree (ea.value);
      report_file_error ("Attaching extended attribute", Fcons (path, Qnil));
    }
  xfree (ea.value);
  return Qnil;
}


DEFUN ("put-ea-list", Fput_ea_list, Sput_ea_list, 2, 3, 0,
  "Attach a list of extended attributes to the file or directory PATH.\n\
EAS is a list of elements (NAME . VECTOR), one element for each\n\
extended attribute.  NAME is the name of the extended attribute,\n\
VECTOR is a vector [FLAGS TYPE SIZE VALUE], where FLAGS is the flags\n\
byte of the extended attribute, TYPE identifies the type of the extended\n\
attribute (`ascii', `binary', `bitmap', `metafile', `icon', `ea', `mvmt',\n\
`mvst', `asn1', or a number), SIZE is the size the value and VALUE is\n\
the (binary) value of the extended attribute, including the type and size\n\
fields.  If TYPE is non-nil, it will override the type field of VALUE.\n\
If SIZE is non-nil, it will override the size field of VALUE.\n\
If the optional third argument REPLACE is non-nil, the existing extended\n\
attributes of the file or directory are removed before attaching the\n\
new extended attributes.")
  (path, eas, replace)
     Lisp_Object path, eas, replace;
{
  _ead ead;
  struct _ea ea;
  Lisp_Object elt, name, vec;
  int rc;
  int count = specpdl_ptr - specpdl;

  CHECK_STRING (path, 0);
  ead = _ead_create ();
  if (!ead)
    report_file_error ("Attaching extended attributes", Fcons (path, Qnil));

  ead_record_unwind_protect (ead);

  while (CONSP (eas))
    {
      elt = XCONS (eas)->car;
      CHECK_CONS (elt, 1);
      name = XCONS (elt)->car;
      vec = XCONS (elt)->cdr;
      CHECK_STRING (name, 1);
      CHECK_VECTOR (vec, 1);
      ea_from_lisp (&ea, vec);
      /* When using emx 0.8h, this requires the C library of emxfix07.  */
      rc = _ead_add (ead, XSTRING (name)->data, ea.flags, ea.value, ea.size);
      xfree (ea.value);
      if (rc < 0)
        report_file_error ("Attaching extended attributes",
                           Fcons (path, Qnil));
      eas = XCONS (eas)->cdr;
    }
  if (!NILP (eas))
    CHECK_CONS (eas, 1);

  if (_ead_write (ead, XSTRING (path)->data, 0,
                  NILP (replace) ? _EAD_MERGE : 0) != 0)
    report_file_error ("Attaching extended attributes", Fcons (path, Qnil));
  return unbind_to (count, Qnil);
}


DEFUN ("put-ea-string", Fput_ea_string, Sput_ea_string, 3, 3, 0,
  "Attach an extended attribute (string) to the file or directory PATH.\n\
NAME is the name of the extended attribute.  VALUE is a string\n\
containing the value.  The flags byte of the extended attribute is\n\
set to 0, the type is set to `ascii', and the size is computed from\n\
the length of the string.")
  (path, name, value)
     Lisp_Object path, name, value;
{
  struct _ea ea;
  char *str;
  int size;

  CHECK_STRING (path, 0);
  CHECK_STRING (name, 1);
  CHECK_STRING (value, 2);

  size = XSTRING (value)->size;
  if (size > 65535 - 4)
    error ("Value of extended attribute too long");
  str = alloca (4 + size);
  bcopy (XSTRING (value)->data, str + 4, size);
  ((USHORT *)str)[0] = EAT_ASCII;
  ((USHORT *)str)[1] = (USHORT)size;
  ea.flags = 0;
  ea.size = 4 + size;
  ea.value = str;
  if (_ea_put (&ea, XSTRING (path)->data, 0, XSTRING (name)->data) != 0)
    report_file_error ("Attaching extended attribute", Fcons (path, Qnil));
  return Qnil;
}


DEFUN ("remove-ea", Fremove_ea, Sremove_ea, 2, 2, 0,
  "Remove extended attribute NAME from the file or directory PATH.")
  (path, name)
     Lisp_Object path, name;
{
  CHECK_STRING (path, 0);
  CHECK_STRING (name, 1);

  if (_ea_remove (XSTRING (path)->data, 0, XSTRING (name)->data) != 0)
    report_file_error ("Removing extended attribute", Fcons (path, Qnil));
  return Qnil;
}


DEFUN ("remove-all-eas", Fremove_all_eas, Sremove_all_eas, 1, 1, 0,
  "Remove all extended attribute from the file or directory PATH.")
  (path)
     Lisp_Object path;
{
  _ead ead;
  int rc;

  CHECK_STRING (path, 0);
  ead = _ead_create ();
  if (!ead)
    report_file_error ("Removing all extended attributes", Fcons (path, Qnil));
  rc = _ead_write (ead, XSTRING (path)->data, 0, 0);
  _ead_destroy (ead);
  if (rc != 0)
    report_file_error ("Removing all extended attributes", Fcons (path, Qnil));
  return Qnil;
}


void
syms_of_emxdep ()
{
  Qascii = intern ("ascii");
  staticpro (&Qascii);
  Qbinary = intern ("binary");
  staticpro (&Qbinary);
  Qbitmap = intern ("bitmap");
  staticpro (&Qbitmap);
  Qmetafile = intern ("metafile");
  staticpro (&Qmetafile);
  Qea = intern ("ea");
  staticpro (&Qea);
  Qmvmt = intern ("mvmt");
  staticpro (&Qmvmt);
  Qmvst = intern ("mvst");
  staticpro (&Qmvst);
  Qasn1 = intern ("asn1");
  staticpro (&Qasn1);

  DEFVAR_LISP ("emx-binary-mode-list", &Vemx_binary_mode_list,
    "*List of regular expressions.  Binary mode is used for files\n\
matching one of the regular expressions.");
  Vemx_binary_mode_list = Qnil;

  DEFVAR_BOOL ("binary-process-input", &binary_process_input,
    "*Non-nil means write process input in binary mode.\n\
nil means use file type of the buffer for writing process input.\n\
binary-process-input is examined by call-process and start-process.");
  binary_process_input = 0;

  DEFVAR_BOOL ("binary-process-output", &binary_process_output,
    "*Non-nil means read process output in binary mode.\n\
nil means use file type of the buffer for reading process output.\n\
binary-process-output is examined by call-process and start-process.");
  binary_process_output = 0;

  DEFVAR_LISP ("emx-system-type", &Vemx_system_type,
    "Underlying operating system (or program loader).\n\
Possible values are `os2' and `ms-dos'.");
  Vemx_system_type = intern (_osmode == OS2_MODE ? "os2" : "ms-dos");

  DEFVAR_LISP ("process-priority", &Vprocess_priority,
    "Priority to be assigned to child processes.\n\
Possible values are nil (child processes inherit the priority of Emacs),\n\
a priority class, or (PCLASS . PLEVEL), where PCLASS is a priority\n\
class and PLEVEL is a priority level.  Available priority classes are:\n\
  idle-time (idle-time priority class),\n\
  regular (regular priority class -- this is the OS/2 default,\n\
    a priority boost is applied if the process is in the foreground), and\n\
  foreground-server (fixed-high priority class).\n\
If PLEVEL is omitted or is nil, a priority level of 0 is used.\n\
Otherwise, PLEVEL shall be a number between 0 and 31 which indicates\n\
  the priority level within the priority class.  Level 31 has the highest\n\
  priority in each class, the default value assigned by OS/2 is 0.");
  Vprocess_priority = Qnil;

  DEFVAR_LISP ("program-name-handler-alist", &Vprogram_name_handler_alist,
    "*Alist of elements (REGEXP . HANDLER) for programs handled specially.\n\
If a file name matches REGEXP, then HANDLER is called to take over the work\n\
of call-process and start-process.\n\
\n\
The first argument given to HANDLER is a list containing the name of the\n\
primitive to be handled and the arguments of the primitive.\n\
For call-process, the list is (call-process INFILE BUFFER DISPLAY);\n\
for start-process, the list is (start-process NAME BUFFER).  The second\n\
argument passed to HANDLER is the file name of the program; the third\n\
argument is a list of the program arguments.  For example, if you do\n\
    (call-process PROGRAM "infile" t nil ARG1 ARG2)\n\
and PROGRAM is handled by HANDLER, then HANDLER is called like this:\n\
    (funcall HANDLER '(call-process "infile" t nil) PROGRAM '(ARG1 ARG2))\n\
HANDLER may modify the structure of its first and third arguments.");
  Vprogram_name_handler_alist = Qnil;

  DEFVAR_LISP ("inhibit-program-name-handlers", &Vinhibit_program_name_handlers,
    "A list of program name handlers that temporarily should not be used.");
  Vinhibit_program_name_handlers = Qnil;

  defsubr (&Scurrent_code_page);
  defsubr (&Slist_code_pages);
  defsubr (&Sset_code_page);
  defsubr (&Semacs_priority);
  defsubr (&Sfilesystem_type);
  defsubr (&Skeyboard_type);
  defsubr (&Sfile_name_valid_p);
  defsubr (&Sremove_from_window_list);
  defsubr (&Spm_session_bond);
  defsubr (&Semx_binary_mode_p);
  defsubr (&Sget_ea);
  defsubr (&Sget_ea_string);
  defsubr (&Sget_ea_list);
  defsubr (&Sput_ea);
  defsubr (&Sput_ea_string);
  defsubr (&Sput_ea_list);
  defsubr (&Sremove_ea);
  defsubr (&Sremove_all_eas);
}