home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 2: Applications / Linux Cubed Series 2 - Applications.iso / editors / emacs / xemacs / xemacs-1.004 / xemacs-1 / xemacs-19.13 / src / callproc.c < prev    next >
Encoding:
C/C++ Source or Header  |  1995-08-18  |  32.8 KB  |  1,255 lines
  1. /* Synchronous subprocess invocation for XEmacs.
  2.    Copyright (C) 1985, 1986, 1987, 1988, 1992, 1993, 1994
  3.    Free Software Foundation, Inc.
  4.  
  5. This file is part of XEmacs.
  6.  
  7. XEmacs is free software; you can redistribute it and/or modify it
  8. under the terms of the GNU General Public License as published by the
  9. Free Software Foundation; either version 2, or (at your option) any
  10. later version.
  11.  
  12. XEmacs is distributed in the hope that it will be useful, but WITHOUT
  13. ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  14. FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  15. for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with XEmacs; see the file COPYING.  If not, write to the Free
  19. Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.  */
  20.  
  21. /* Synched up with: Mule 2.0, FSF 19.28. */
  22.  
  23. #include <config.h>
  24. #include "lisp.h"
  25.  
  26. #include "buffer.h"
  27. #include "commands.h"
  28. #include "insdel.h"
  29. #include "lstream.h"
  30. #include "mule.h"
  31. #include "paths.h"
  32. #include "process.h"
  33. #include "sysdep.h"
  34. #include "window.h"
  35.  
  36. #include "sysfile.h"
  37. #include "systime.h"
  38. #include "sysproc.h"
  39. #include "syssignal.h" /* Always include before systty.h */
  40. #include "systty.h"
  41.  
  42.  
  43. #ifdef MSDOS
  44. /* When we are starting external processes we need to know whether they
  45.    take binary input (no conversion) or text input (\n is converted to
  46.    \r\n).  Similar for output: if newlines are written as \r\n then it's
  47.    text process output, otherwise it's binary.  */
  48. Lisp_Object Vbinary_process_input;
  49. Lisp_Object Vbinary_process_output;
  50. #endif
  51.  
  52. Lisp_Object Vexec_path, Vexec_directory, Vdata_directory, Vdoc_directory;
  53. Lisp_Object Vconfigure_info_directory;
  54.  
  55. Lisp_Object Vshell_file_name;
  56.  
  57. /* The environment to pass to all subprocesses when they are started.
  58.    This is in the semi-bogus format of ("VAR=VAL" "VAR2=VAL2" ... )
  59.  */
  60. Lisp_Object Vprocess_environment;
  61.  
  62. /* True iff we are about to fork off a synchronous process or if we
  63.    are waiting for it.  */
  64. volatile int synch_process_alive;
  65.  
  66. /* Nonzero => this is a string explaining death of synchronous subprocess.  */
  67. CONST char *synch_process_death;
  68.  
  69. /* If synch_process_death is zero,
  70.    this is exit code of synchronous subprocess.  */
  71. int synch_process_retcode;
  72.  
  73. /* Clean up when exiting Fcall_process_internal.
  74.    On MSDOS, delete the temporary file on any kind of termination.
  75.    On Unix, kill the process and any children on termination by signal.  */
  76.  
  77. /* Nonzero if this is termination due to exit.  */
  78. static int call_process_exited;
  79.  
  80. #ifndef VMS  /* VMS version is in vmsproc.c.  */
  81.  
  82. static Lisp_Object
  83. call_process_kill (Lisp_Object fdpid)
  84. {
  85.   Lisp_Object fd = Fcar (fdpid);
  86.   Lisp_Object pid = Fcdr (fdpid);
  87.  
  88.   if (!NILP (fd))
  89.     close (XINT (fd));
  90.  
  91.   if (!NILP (pid))
  92.     EMACS_KILLPG (XINT (pid), SIGKILL);
  93.   
  94.   synch_process_alive = 0;
  95.   return Qnil;
  96. }
  97.  
  98. static Lisp_Object
  99. call_process_cleanup (Lisp_Object fdpid)
  100. {
  101. #ifdef MSDOS
  102.   /* for MSDOS fdpid is really (fd . tempfile)  */
  103.   Lisp_Object file = Fcdr (fdpid);
  104.   close (XINT (Fcar (fdpid)));
  105.   if (strcmp (string_ext_data (XSTRING (file)), NULL_DEVICE) != 0)
  106.     unlink (string_data (XSTRING (file)));
  107. #else /* not MSDOS */
  108.   int fd = XINT (Fcar (fdpid));
  109.   int pid = XINT (Fcdr (fdpid));
  110.  
  111. #ifdef WIN32
  112.   CloseHandle (XINT (Fcar (fdpid))); /* fd = Fcar (fdpid) */
  113. #else
  114.   if (!call_process_exited &&
  115.       EMACS_KILLPG (pid, SIGINT) == 0)
  116.   {
  117.     int speccount = specpdl_depth ();
  118.  
  119.     record_unwind_protect (call_process_kill, fdpid);
  120.     /* #### "c-G" -- need non-consing Single-key-description */
  121.     message ("Waiting for process to die...(type C-g again to kill it instantly)");
  122.  
  123.     /* "Discard" the unwind protect.  */
  124.     XCAR (fdpid) = Qnil;
  125.     XCDR (fdpid) = Qnil;
  126.     unbind_to (speccount, Qnil);
  127.  
  128.     message ("Waiting for process to die... done");
  129.   }
  130. #endif /* not WIN32 */
  131.   synch_process_alive = 0;
  132.   close (fd);
  133. #endif /* not MSDOS */
  134.   return Qnil;
  135. }
  136.  
  137. static Lisp_Object fork_error;
  138. #if 0 /* UNUSED */
  139. static void
  140. report_fork_error (char *string, Lisp_Object data)
  141. {
  142.   Lisp_Object errstring = build_string (strerror (errno));
  143.  
  144.   /* System error messages are capitalized.  Downcase the initial. */
  145.   set_string_char (XSTRING (errstring), 0,
  146.            DOWNCASE (current_buffer,
  147.                  string_char (XSTRING (errstring), 0)));
  148.  
  149.   fork_error = Fcons (build_string (string), Fcons (errstring, data));
  150.  
  151.   /* terminate this branch of the fork, without closing stdin/out/etc. */
  152.   _exit (1);
  153. }
  154. #endif /* unused */
  155.  
  156. DEFUN ("call-process-internal", Fcall_process_internal,
  157.        Scall_process_internal, 1, MANY, 0,
  158.   "Call PROGRAM synchronously in separate process, with coding-system specified.\n\
  159. Arguments are\n\
  160.  (PROGRAM &optional INFILE BUFFER DISPLAY &rest ARGS).\n\
  161. The program's input comes from file INFILE (nil means `/dev/null').\n\
  162. Insert output in BUFFER before point; t means current buffer;\n\
  163.  nil for BUFFER means discard it; 0 means discard and don't wait.\n\
  164. Fourth arg DISPLAY non-nil means redisplay buffer as output is inserted.\n\
  165. Remaining arguments are strings passed as command arguments to PROGRAM.\n\
  166. If BUFFER is 0, returns immediately with value nil.\n\
  167. Otherwise waits for PROGRAM to terminate and returns a numeric exit status\n\
  168.  or a signal description string.\n\
  169. If you quit, the process is killed with SIGINT, or SIGKILL if you\n\
  170.  quit again.")
  171.   (nargs, args)
  172.      int nargs;
  173.      Lisp_Object *args;
  174. {
  175.   /* This function can GC */
  176.   Lisp_Object infile, buffer, current_dir, display, path;
  177.   int fd[2];
  178.   int filefd;
  179.   int pid;
  180.   char buf[1024];
  181.   int speccount = specpdl_depth ();
  182.   char **new_argv
  183.     = (char **) alloca ((max (2, nargs - 2)) * sizeof (char *));
  184.   
  185. #ifdef MSDOS
  186.   char *outf, *tempfile;
  187.   int outfilefd;
  188. #endif
  189.   
  190.   CHECK_STRING (args[0], 0);
  191.  
  192. #if defined (NO_SUBPROCESSES)
  193.   /* Without asynchronous processes we cannot have BUFFER == 0.  */
  194.   if (nargs >= 3 && !INTP (args[2]))
  195.     error ("Operating system cannot handle asynchronous subprocesses");
  196. #endif
  197.  
  198.   /* Do this before building new_argv because GC in Lisp code
  199.    *  called by various filename-hacking routines might relocate strings */
  200.   locate_file (Vexec_path, args[0], EXEC_SUFFIXES, &path, X_OK);
  201.  
  202.   /* Make sure that the child will be able to chdir to the current
  203.      buffer's current directory, or its unhandled equivalent.  We
  204.      can't just have the child check for an error when it does the
  205.      chdir, since it's in a vfork. */
  206.   {
  207.     struct gcpro gcpro1, gcpro2;
  208.     /* Do this test before building new_argv because GC in Lisp code 
  209.      *  called by various filename-hacking routines might relocate strings */
  210.     /* Make sure that the child will be able to chdir to the current
  211.        buffer's current directory.  We can't just have the child check
  212.        for an error when it does the chdir, since it's in a vfork.  */
  213.  
  214.     GCPRO2 (current_dir, path);   /* Caller gcprotects args[] */
  215.     current_dir = current_buffer->directory;
  216.     current_dir = expand_and_dir_to_file
  217.       (Funhandled_file_name_directory (current_dir), Qnil);
  218. #if 0
  219.   /* I don't know how RMS intends this crock of shit to work, but it
  220.      breaks everything in the presence of ange-ftp-visited files, so
  221.      fuck it. */
  222.     if (NILP (Ffile_accessible_directory_p (current_dir)))
  223.       report_file_error ("Setting current directory",
  224.                          Fcons (current_buffer->directory, Qnil));
  225. #endif /* 0 */
  226.     UNGCPRO;
  227.   }
  228.  
  229.   if (nargs >= 2 && ! NILP (args[1]))
  230.     {
  231.       infile = Fexpand_file_name (args[1],
  232.                   current_buffer->directory);
  233.       CHECK_STRING (infile, 1);
  234.     }
  235.   else
  236.     infile = build_string (NULL_DEVICE);
  237.  
  238.   if (nargs >= 3)
  239.     {
  240.       buffer = args[2];
  241.       if (!(EQ (buffer, Qnil)
  242.         || EQ (buffer, Qt)
  243.         || EQ (buffer, Qzero)))
  244.     {
  245.       buffer = Fget_buffer (buffer);
  246.       CHECK_BUFFER (buffer, 2);
  247.     }
  248.     }
  249.   else 
  250.     buffer = Qnil;
  251.  
  252.   display = ((nargs >= 4) ? args[3] : Qnil);
  253.  
  254.   /* From here we assume we won't GC (unless an error is signalled). */
  255.   {
  256.     REGISTER int i;
  257.     for (i = 4; i < nargs; i++)
  258.       {
  259.     CHECK_STRING (args[i], i);
  260.     new_argv[i - 3] = (char *) string_data (XSTRING (args[i]));
  261.       }
  262.     /* Program name is first command arg */
  263.     new_argv[0] = (char *) string_data (XSTRING (args[0]));
  264.     new_argv[i - 3] = 0;
  265.   }
  266.  
  267.   filefd = open ((char *) string_data (XSTRING (infile)), O_RDONLY, 0);
  268.   if (filefd < 0)
  269.     {
  270.       report_file_error ("Opening process input file",
  271.              Fcons (infile, Qnil));
  272.     }
  273.  
  274.   if (NILP (path))
  275.     {
  276.       close (filefd);
  277.       report_file_error ("Searching for program",
  278.              Fcons (args[0], Qnil));
  279.     }
  280.   new_argv[0] = (char *) string_data (XSTRING (path));
  281.   
  282. #ifdef MSDOS
  283.   /* These vars record information from process termination.
  284.      Clear them now before process can possibly terminate,
  285.      to avoid timing error if process terminates soon.  */
  286.   synch_process_death = 0;
  287.   synch_process_retcode = 0;
  288.  
  289.   if ((outf = egetenv ("TMP")) || (outf = egetenv ("TEMP")))
  290.     strcpy (tempfile = alloca (strlen (outf) + 20), outf);
  291.   else
  292.     {
  293.       tempfile = alloca (20);
  294.       *tempfile = '\0';
  295.     }
  296.   dostounix_filename (tempfile);
  297.   if (*tempfile == '\0' || tempfile[strlen (tempfile) - 1] != '/') 
  298.     strcat (tempfile, "/");
  299.   strcat (tempfile, "detmp.XXX");
  300.   mktemp (tempfile);
  301.  
  302.   outfilefd = creat (tempfile, S_IREAD | S_IWRITE);
  303.   if (outfilefd < 0)
  304.     {
  305.       close (filefd);
  306.       report_file_error ("Opening process output file",
  307.              Fcons (tempfile, Qnil));
  308.     }
  309. #endif
  310.  
  311. #ifndef MSDOS
  312.   if (INTP (buffer))
  313.     {
  314.       fd[1] = open (NULL_DEVICE, O_WRONLY, 0);
  315.       fd[0] = -1;
  316.     }
  317.   else
  318.     {
  319.       pipe (fd);
  320. #if 0
  321.       /* Replaced by close_process_descs */
  322.       set_exclusive_use (fd[0]);
  323. #endif
  324.     }
  325. #else /* MSDOS */
  326.   {
  327.     char *outf;
  328.  
  329.   if (INTP (buffer))
  330.     outf = NULL_DEVICE;
  331.   else 
  332.     {
  333.     /* DOS can't create pipe for interprocess communication, 
  334.        so redirect child process's standard output to temporary file
  335.        and later read the file. */
  336.     
  337.       if ((outf = egetenv ("TMP")) || (outf = egetenv ("TEMP")))
  338.     {
  339.       strcpy (tempfile, outf);
  340.       dostounix_filename (tempfile);
  341.     }
  342.       else
  343.         *tempfile = '\0';
  344.       if (strlen (tempfile) == 0 || tempfile[strlen (tempfile) - 1] != '/')
  345.     strcat (tempfile, "/");
  346.       strcat (tempfile, "demacs.XXX");
  347.       mktemp (tempfile);
  348.       outf = tempfile;
  349.     }
  350.  
  351.     if ((fd[1] = creat (outf, S_IREAD | S_IWRITE)) < 0)
  352.       report_file_error ("Can't open temporary file", Qnil);
  353.     fd[0] = -1;
  354.     }
  355. #endif /* MSDOS */
  356.  
  357.    {
  358.      /* child_setup must clobber environ in systems with true vfork.
  359.     Protect it from permanent change.  */
  360.      REGISTER char **save_environ = environ;
  361.      REGISTER int fd1 = fd[1];
  362.      char **env;
  363.  
  364. #ifdef EMACS_BTL
  365.     /* when performance monitoring is on, turn it off before the vfork(),
  366.        as the child has no handler for the signal -- when back in the
  367.        parent process, turn it back on if it was really on when you "turned
  368.        it off" */
  369.     int logging_on = cadillac_stop_logging ();
  370. #endif
  371.  
  372.     env = environ;
  373.  
  374.     /* Record that we're about to create a synchronous process.  */
  375.     synch_process_alive = 1;
  376.  
  377.     /* These vars record information from process termination.
  378.        Clear them now before process can possibly terminate,
  379.        to avoid timing error if process terminates soon.  */
  380.     synch_process_death = 0;
  381.     synch_process_retcode = 0;
  382.  
  383. #ifdef MSDOS
  384.     /* ??? Someone who knows MSDOG needs to check whether this properly
  385.        closes all descriptors that it opens.  */
  386.     pid = run_msdos_command (new_argv, current_dir, filefd, outfilefd);
  387.     close (outfilefd);
  388.     fd1 = -1; /* No harm in closing that one!  */
  389.     fd[0] = open (tempfile, NILP (Vbinary_process_output) ? O_TEXT :
  390.             O_BINARY);
  391.     if (fd[0] < 0)
  392.       {
  393.     unlink (tempfile);
  394.     close (filefd);
  395.     report_file_error ("Cannot re-open temporary file", Qnil);
  396.       }
  397. #else /* not MSDOS */
  398. #ifdef WIN32
  399.     {
  400.       HANDLE temp;
  401.       
  402.       DuplicateHandle (GetCurrentProcess (), (HANDLE) fd[0],
  403.                        GetCurrentProcess (), &temp, 0,
  404.                FALSE, DUPLICATE_SAME_ACCESS);
  405.  
  406.       CloseHandle ((HANDLE) fd[0]);
  407.       fd[0] = (int) temp; /* for later access */
  408.  
  409.       child_setup (filefd, fd1, fd1, new_argv, env);
  410.     }
  411. #else /* not WIN32 */
  412.     fork_error = Qnil;
  413.     pid = vfork ();
  414.  
  415.     if (pid == 0)
  416.       {
  417.     if (fd[0] >= 0)
  418.       close (fd[0]);
  419.     /* This is necessary because some shells may attempt to
  420.        access the current controlling terminal and will hang
  421.        if they are run in the background, as will be the case
  422.        when XEmacs is started in the background.  Martin
  423.        Buchholz observed this problem running a subprocess
  424.        that used zsh to call gzip to uncompress an info
  425.        file. */
  426.     disconnect_controlling_terminal ();
  427. #ifndef MSDOS
  428.     child_setup (filefd, fd1, fd1, new_argv, env,
  429.                      (char *) string_data (XSTRING (current_dir)));
  430. #endif
  431.       }
  432. #ifdef EMACS_BTL
  433.     else if (logging_on)
  434.       cadillac_start_logging ();
  435. #endif
  436.  
  437. #endif /* not WIN32 */
  438. #endif /* not MSDOS */
  439.  
  440.     environ = save_environ;
  441.  
  442.     /* Close most of our fd's, but not fd[0]
  443.        since we will use that to read input from.  */
  444.     close (filefd);
  445. #ifdef WIN32
  446.     if (fd1 >= 0)
  447.       CloseHandle ((HANDLE) fd1);
  448. #else /* not WIN32 */
  449.     if (fd1 >= 0)
  450.       close (fd1);
  451. #endif /* not WIN32 */
  452.   }
  453.  
  454.   if (!NILP (fork_error))
  455.     signal_error (Qfile_error, fork_error);
  456.  
  457. #if !defined (WIN32)
  458.   if (pid < 0)
  459.     {
  460.       if (fd[0] >= 0)
  461.     close (fd[0]);
  462.       report_file_error ("Doing vfork", Qnil);
  463.     }
  464. #endif /* not WIN32 */
  465.  
  466.   if (INTP (buffer))
  467.     {
  468.       if (fd[0] >= 0)
  469.     close (fd[0]);
  470. #if defined (NO_SUBPROCESSES)
  471.       /* If Emacs has been built with asynchronous subprocess support,
  472.      we don't need to do this, I think because it will then have
  473.      the facilities for handling SIGCHLD.  */
  474.       wait_without_blocking ();
  475. #endif
  476.       return Qnil;
  477.     }
  478.  
  479.   {
  480.     int nread;
  481.     int first;
  482.     int state = 1;
  483.     Lisp_Object instream;
  484.     struct gcpro gcpro1;
  485.  
  486.     /* Enable sending signal if user quits below.  */
  487.     call_process_exited = 0;
  488.  
  489. #ifdef MSDOS
  490.     /* MSDOS needs different cleanup information.  */
  491.     record_unwind_protect (call_process_cleanup,
  492.                            Fcons (make_number (fd[0]),
  493.                                   build_string (tempfile)));
  494. #else
  495.     record_unwind_protect (call_process_cleanup,
  496.                            Fcons (make_number (fd[0]), make_number (pid)));
  497. #endif /* not MSDOS */
  498.  
  499.     first = 1;
  500.     if (EQ (buffer, Qt))
  501.       XSETBUFFER (buffer, current_buffer);
  502.     instream = make_filedesc_stream (fd[0], LSTR_ALLOW_QUIT);
  503. #ifdef MULE
  504.     instream =
  505.       make_mule_encoding_stream
  506.     (XLSTREAM (instream),
  507.      decode_coding_system_variable (Vprocess_input_coding_system));
  508. #endif
  509.     GCPRO1 (instream);
  510.     while (state)
  511.       {
  512.     QUIT;
  513.     nread = Lstream_read (XLSTREAM (instream), buf, sizeof buf);
  514.     if (nread <= 0) state = 0;
  515.     if (!NILP (buffer))
  516.       {
  517.         if (state)
  518.           buffer_insert_raw_string (XBUFFER (buffer), (Bufbyte *) buf,
  519.                     nread);
  520.       }
  521.     if (!NILP (display) && INTERACTIVE)
  522.       {
  523.         first = 0;
  524.         redisplay ();
  525.       }
  526.       }
  527.     Lstream_close (XLSTREAM (instream));
  528.     UNGCPRO;
  529.  
  530.     QUIT;
  531. #ifndef MSDOS
  532.     /* Wait for it to terminate, unless it already has.  */
  533.     wait_for_termination (pid);
  534. #endif
  535.  
  536.     /* Don't kill any children that the subprocess may have left behind
  537.        when exiting.  */
  538.     call_process_exited = 1;
  539.     unbind_to (speccount, Qnil);
  540.  
  541.     if (synch_process_death)
  542.       return build_string (synch_process_death);
  543.     return make_number (synch_process_retcode);
  544.   }
  545. }
  546.  
  547. #endif /* VMS */
  548.  
  549. #ifndef VMS /* VMS version is in vmsproc.c.  */
  550.  
  551. /* This is the last thing run in a newly forked inferior
  552.    either synchronous or asynchronous.
  553.    Copy descriptors IN, OUT and ERR as descriptors 0, 1 and 2.
  554.    Initialize inferior's priority, pgrp, connected dir and environment.
  555.    then exec another program based on new_argv.
  556.  
  557.    This function may change environ for the superior process.
  558.    Therefore, the superior process must save and restore the value
  559.    of environ around the vfork and the call to this function.
  560.  
  561.    ENV is the environment for the subprocess.
  562.  
  563.    CURRENT_DIR is an elisp string giving the path of the current
  564.    directory the subprocess should have.  Since we can't really signal
  565.    a decent error from within the child, this should be verified as an
  566.    executable directory by the parent.  */
  567.  
  568. #ifdef MSDOS
  569.  
  570. child_setup (int in, int out, int err, char **new_argv, char **env)
  571. {
  572.   int i;
  573.   int st;
  574.   char oldwd[MAXPATHLEN+1];
  575. #ifdef GO32
  576.   char com[256];
  577.  
  578.   *com = '\0';
  579.   /* Copy command name into command line buffer. */
  580.   {
  581.     char *suffix = strchr (new_argv[0], '.');
  582.     if (strncmp (new_argv[0], ".bat", 4))
  583.       {
  584.         strcat (com, string_data (XSTRING (Vshell_file_name)));
  585.         strcat (com, " -c ");
  586.       }
  587.   }
  588.   strcat (com, new_argv[0]);
  589.   strcat (com, " ");
  590.   /* Convert path delimiter in command name into MSDOS fashon. */
  591.   {
  592.     char *p;
  593.     for (p = com; *p; p++)
  594.       if (*p == '/')
  595.     *p = '\\';
  596.       else if (*p == '-')
  597.         *p = '/';
  598.   }
  599.   for (i = 1; new_argv[i]; i++)
  600.     strcat (strcat (com, new_argv[i]), " ");
  601. #endif /* GO32 */
  602.  
  603.   getwd (oldwd);
  604.     
  605.   {
  606.     /* change directory */
  607.     if (STRINGP (current_buffer->directory))
  608.       {
  609.     unsigned char *temp;
  610.     int i;
  611.     
  612.     i = string_length (XSTRING (current_buffer->directory));
  613.     temp = (unsigned char *) alloca (i + 2);
  614.     memcpy (temp, string_data (XSTRING (current_buffer->directory)), i);
  615.     if (temp[i - 1] != '/') temp[i++] = '/';
  616.     temp[i] = 0;
  617.     chdir (temp);
  618.       }
  619.   }
  620.     
  621.   {
  622.     int inbak, outbak, errbak;
  623.  
  624.     inbak = dup (0); outbak = dup (1); errbak = dup (2);
  625.     if (inbak < 0 || outbak < 0 || errbak < 0)
  626.       goto skip;
  627.  
  628.     dup2 (in, 0);
  629.     dup2 (out, 1);
  630.     dup2 (out, 2);
  631.     
  632. #ifdef GO32
  633.     synch_process_retcode = system (com);
  634. #else
  635. #ifdef EMX
  636.     synch_process_retcode
  637.       = spawnvpe (P_WAIT, new_argv[0], (char **) new_argv, (char **) environ);
  638. #endif
  639. #endif
  640.       
  641.     close (in);
  642.     close (out);
  643.     dup2 (inbak, 0); dup2 (outbak, 1); dup2 (errbak, 2);
  644.       
  645.   skip:
  646.     close (inbak); close (outbak); close (errbak);
  647.   }
  648.  
  649.   chdir (oldwd);
  650. #if 0
  651.   if (synch_process_retcode < 0)
  652.     report_file_error ("Can't execute", Fcons (args[0], Qnil));
  653. #endif
  654. }
  655.  
  656. #else /* not MSDOS */
  657. #ifdef WIN32
  658.  
  659. child_setup (int in, int out, int err, char **new_argv, char **env)
  660. {
  661.   int i;
  662.   int st;
  663.   char *com;
  664. #if 1
  665.   char oldwd[MAXPATHLEN+1];
  666. #else
  667.   char *asynch_process_directory;
  668. #endif
  669.  
  670.   com = (char *) malloc (1024);
  671.   *com = '\0';
  672.   /* Copy command name into command line buffer. */
  673.   {
  674.     char *suffix = strchr (new_argv[0], '.');
  675.     if (strncmp (new_argv[0], ".bat", 4))
  676.       {
  677.         lstrcpy (com, string_data (XSTRING (Vshell_file_name)));
  678.         lstrcat (com, " -c ");
  679.       }
  680.   }
  681.   lstrcat (com, new_argv[0]);
  682.   lstrcat (com, " ");
  683.   /* Convert path delimiter in command name into MSDOS fashon. */
  684.   {
  685.     char *p;
  686.     for (p = com; *p; p++)
  687.       if (*p == '/')
  688.     *p = '\\';
  689.       else if (*p == '-')
  690.         *p = '/';
  691.   }
  692.   for (i = 1; new_argv[i]; i++)
  693.     lstrcat (lstrcat (com, new_argv[i]), " ");
  694.  
  695. #if 1
  696.   getwd (oldwd);
  697.     
  698.   {
  699.     /* change directory */
  700.     if (STRINGP (current_buffer->directory))
  701.       {
  702.     unsigned char *temp;
  703.     int i;
  704.     
  705.     i = string_length (XSTRING (current_buffer->directory));
  706.     temp = (unsigned char *) alloca (i + 2);
  707.     memcpy (temp, string_data (XSTRING (current_buffer->directory)), i);
  708.     if (temp[i - 1] != '/') temp[i++] = '/';
  709.     temp[i] = 0;
  710.     chdir (temp);
  711.       }
  712.   }
  713. #else
  714.   if (STRINGP (current_buffer->directory))
  715.     {
  716.       int i;
  717.       
  718.       i = string_length (XSTRING (current_buffer->directory));
  719.       asynch_process_directory = (unsigned char *) alloca (i + 2);
  720.       memcpy (asynch_process_directory,
  721.           string_data (XSTRING (current_buffer->directory)), i);
  722.       if (asynch_process_directory[i - 1] != '/')
  723.     asynch_process_directory[i++] = '/';
  724.       asynch_process_directory[i] = 0;
  725.     }
  726. #endif
  727.     
  728.     {
  729.       extern HANDLE hStdin, hStdout, hStderr;
  730.  
  731.       if (in && out && err) {
  732.     if (!SetStdHandle (STD_INPUT_HANDLE, (HANDLE) in) ||
  733.         !SetStdHandle (STD_OUTPUT_HANDLE, (HANDLE) out) ||
  734.         !SetStdHandle (STD_ERROR_HANDLE, (HANDLE) err))
  735.       goto restore;
  736.       }
  737.  
  738.       {
  739.         PROCESS_INFORMATION piProcInfo;
  740.     STARTUPINFO siStartInfo;
  741.         
  742.     /* Set up fields of STARTUPINFO structure */
  743.     siStartInfo.cb = sizeof (STARTUPINFO);
  744.     siStartInfo.lpReserved = 0;
  745.     siStartInfo.lpReserved2 = 0;
  746.     siStartInfo.cbReserved2 = 0;
  747.     siStartInfo.lpDesktop = 0;
  748.     siStartInfo.dwFlags = 0;
  749.  
  750.     /* Create child process */
  751.         {
  752.       st = CreateProcess ((LPCTSTR) 0,
  753.                   (LPCTSTR) com,
  754.                           (LPSECURITY_ATTRIBUTES) 0,
  755.                   (LPSECURITY_ATTRIBUTES) 0, 
  756.                   TRUE,  /* inherit handles */
  757.                   0,
  758.                   (LPVOID) 0,
  759. #if 1
  760.                   (LPTSTR) 0,
  761. #else
  762.                   asnych_process_directory,
  763. #endif
  764.                   &siStartInfo, &piProcInfo);
  765.     }
  766.       }
  767.       
  768.     restore:
  769.       if (in && out && err) {
  770.     SetStdHandle (STD_INPUT_HANDLE,  hStdin);
  771.     SetStdHandle (STD_OUTPUT_HANDLE, hStdout);
  772.     SetStdHandle (STD_ERROR_HANDLE,  hStderr);
  773.       }
  774.     }
  775.  
  776.   free (com);
  777. #if 1
  778.   chdir (oldwd);
  779. #endif
  780.     if (!st)
  781.       report_file_error ("Can't execute", Fcons (new_argv[0], Qnil));
  782. }
  783.  
  784. #else /* not WIN32 */
  785.  
  786. static int relocate_fd (int fd, int min);
  787.  
  788. void
  789. child_setup (int in, int out, int err, char **new_argv, char **env,
  790.          CONST char *current_dir)
  791. {
  792.   char *pwd;
  793.  
  794. #ifdef SET_EMACS_PRIORITY
  795.   if (emacs_priority != 0)
  796.     nice (- emacs_priority);
  797. #endif
  798.  
  799. #if !defined (NO_SUBPROCESSES)
  800.   /* Close Emacs's descriptors that this process should not have.  */
  801.   close_process_descs ();
  802. #endif
  803.   close_load_descs ();
  804.  
  805.   /* Note that use of alloca is always safe here.  It's obvious for systems
  806.      that do not have true vfork or that have true (stack) alloca.
  807.      If using vfork and C_ALLOCA it is safe because that changes
  808.      the superior's static variables as if the superior had done alloca
  809.      and will be cleaned up in the usual way.  */
  810.   {
  811.     REGISTER int i;
  812.  
  813.     i = strlen (current_dir);
  814.     pwd = (char *) alloca (i + 6);
  815.     memcpy (pwd, "PWD=", 4);
  816.     memcpy (pwd + 4, current_dir, i);
  817.     i += 4;
  818.     if (pwd[i - 1] != '/')
  819.       pwd[i++] = '/';
  820.     pwd[i] = 0;
  821.  
  822.     /* We can't signal an Elisp error here; we're in a vfork.  Since
  823.        the callers check the current directory before forking, this
  824.        should only return an error if the directory's permissions
  825.        are changed between the check and this chdir, but we should
  826.        at least check.  */
  827.     if (chdir (pwd + 4) < 0)
  828.       {
  829.     /* Don't report the chdir error, or ange-ftp.el doesn't work. */
  830.     pwd = 0;
  831.       }
  832.     else
  833.       {
  834.     /* Strip trailing "/".  Cretinous *[]&@$#^%@#$% Un*x */
  835.     /* leave "//" (from FSF) */
  836.     while (i > 6 && pwd[--i] == '/')
  837.       pwd[i] = 0;
  838.       }
  839.   }
  840.  
  841.   /* Set `env' to a vector of the strings in Vprocess_environment.  */
  842.   {
  843.     REGISTER Lisp_Object tem;
  844.     REGISTER char **new_env;
  845.     REGISTER int new_length;
  846.  
  847.     new_length = 0;
  848.     for (tem = Vprocess_environment;
  849.      (CONSP (tem)
  850.       && STRINGP (XCAR (tem)));
  851.      tem = XCDR (tem))
  852.       new_length++;
  853.  
  854.     /* new_length + 2 to include PWD and terminating 0.  */
  855.     env = new_env = (char **) alloca ((new_length + 2) * sizeof (char *));
  856.  
  857.     /* If we have a PWD envvar and we know the real current directory,
  858.        pass one down, but with corrected value.  */
  859.     if (pwd && getenv ("PWD"))
  860.       *new_env++ = pwd;
  861.  
  862.     /* Copy the Vprocess_environment strings into new_env.  */
  863.     for (tem = Vprocess_environment;
  864.      (CONSP (tem)
  865.       && STRINGP (XCAR (tem)));
  866.      tem = XCDR (tem))
  867.     {
  868.       char **ep = env;
  869.       char *string = (char *) string_data (XSTRING (XCAR (tem)));
  870.       /* See if this string duplicates any string already in the env.
  871.      If so, don't put it in.
  872.      When an env var has multiple definitions,
  873.      we keep the definition that comes first in process-environment.  */
  874.       for (; ep != new_env; ep++)
  875.     {
  876.       char *p = *ep, *q = string;
  877.       while (1)
  878.         {
  879.           if (*q == 0)
  880.         /* The string is malformed; might as well drop it.  */
  881.         goto duplicate;
  882.           if (*q != *p)
  883.         break;
  884.           if (*q == '=')
  885.         goto duplicate;
  886.           p++, q++;
  887.         }
  888.     }
  889.       if (pwd && !strncmp ("PWD=", string, 4))
  890.     {
  891.       *new_env++ = pwd;
  892.       pwd = 0;
  893.     }
  894.       else
  895.         *new_env++ = string;
  896.     duplicate: ;
  897.     }
  898.     *new_env = 0;
  899.   }
  900.  
  901.   /* Make sure that in, out, and err are not actually already in
  902.      descriptors zero, one, or two; this could happen if Emacs is
  903.      started with its standard in, out, or error closed, as might
  904.      happen under X.  */
  905.   in = relocate_fd (in, 3);
  906.   if (out == err)
  907.     err = out = relocate_fd (out, 3);
  908.   else
  909.     {
  910.       out = relocate_fd (out, 3);
  911.       err = relocate_fd (err, 3);
  912.     }
  913.  
  914.   close (0);
  915.   close (1);
  916.   close (2);
  917.  
  918.   dup2 (in, 0);
  919.   dup2 (out, 1);
  920.   dup2 (err, 2);
  921.   close (in);
  922.   close (out);
  923.   close (err);
  924.  
  925. #ifdef vipc
  926.   something missing here;
  927. #endif /* vipc */
  928.  
  929.   /* execvp does not accept an environment arg so the only way
  930.      to pass this environment is to set environ.  Our caller
  931.      is responsible for restoring the ambient value of environ.  */
  932.   environ = env;
  933.   execvp (new_argv[0], new_argv);
  934.  
  935.   stdout_out ("Couldn't exec the program %s", new_argv[0]);
  936.   _exit (1);
  937. }
  938.  
  939. #endif /* not WIN32 */
  940. #endif /* not MSDOS */
  941.  
  942. /* Move the file descriptor FD so that its number is not less than MIN.
  943.    If the file descriptor is moved at all, the original is freed.  */
  944. static int
  945. relocate_fd (int fd, int min)
  946. {
  947.   if (fd >= min)
  948.     return fd;
  949.   else
  950.     {
  951.       int new = dup (fd);
  952.       if (new == -1)
  953.     {
  954.       stderr_out ("Error while setting up child: %s\n",
  955.               strerror (errno), "\n");
  956.       _exit (1);
  957.     }
  958.       /* Note that we hold the original FD open while we recurse,
  959.      to guarantee we'll get a new FD if we need it.  */
  960.       new = relocate_fd (new, min);
  961.       close (fd);
  962.       return new;
  963.     }
  964. }
  965.  
  966. static int
  967. getenv_internal (CONST Bufbyte *var,
  968.          Bytecount varlen,
  969.          Bufbyte **value,
  970.          Bytecount *valuelen)
  971. {
  972.   Lisp_Object scan;
  973.  
  974.   for (scan = Vprocess_environment; CONSP (scan); scan = XCDR (scan))
  975.     {
  976.       Lisp_Object entry = XCAR (scan);
  977.       
  978.       if (STRINGP (entry)
  979.       && string_length (XSTRING (entry)) > varlen
  980.       && string_byte (XSTRING (entry), varlen) == '='
  981.       && ! memcmp (string_data (XSTRING (entry)), var, varlen))
  982.     {
  983.       *value    = string_data (XSTRING (entry)) + (varlen + 1);
  984.       *valuelen = string_length (XSTRING (entry)) - (varlen + 1);
  985.       return 1;
  986.     }
  987.     }
  988.  
  989.   return 0;
  990. }
  991.  
  992. DEFUN ("getenv", Fgetenv, Sgetenv, 1, 2, "sEnvironment variable: \np",
  993.   "Return the value of environment variable VAR, as a string.\n\
  994. VAR is a string, the name of the variable.\n\
  995. When invoked interactively, prints the value in the echo area.")
  996.      (var, interactivep)
  997.      Lisp_Object var, interactivep;
  998. {
  999.   Bufbyte *value;
  1000.   Bytecount valuelen;
  1001.   Lisp_Object v = Qnil;
  1002.   struct gcpro gcpro1;
  1003.  
  1004.   CHECK_STRING (var, 0);
  1005.   GCPRO1 (v);
  1006.   if (getenv_internal (string_data (XSTRING (var)),
  1007.                string_length (XSTRING (var)),
  1008.                &value, &valuelen))
  1009.     v = make_string (value, valuelen);
  1010.   if (!NILP (interactivep))
  1011.     {
  1012.       if (NILP (v))
  1013.     message ("%s not defined in environment",
  1014.          string_data (XSTRING (var)));
  1015.       else
  1016.     message ("\"%s\"", value);
  1017.     }
  1018.   RETURN_UNGCPRO (v);
  1019. }
  1020.  
  1021. /* A version of getenv that consults process_environment, easily
  1022.    callable from C.  */
  1023. char *
  1024. egetenv (CONST char *var)
  1025. {
  1026.   Bufbyte *value;
  1027.   Bytecount valuelen;
  1028.  
  1029.   if (getenv_internal ((Bufbyte *) var, strlen (var), &value, &valuelen))
  1030.     return (char *) value;
  1031.   else
  1032.     return 0;
  1033. }
  1034. #endif /* not VMS */
  1035.  
  1036.  
  1037. void
  1038. init_callproc (void)
  1039. {
  1040.   /* This function can GC */
  1041.   REGISTER char *sh;
  1042.   Lisp_Object tempdir;
  1043.  
  1044.   Vprocess_environment = Qnil;
  1045.   /* jwz: always initialize Vprocess_environment, so that egetenv() works
  1046.      in temacs. */
  1047.   {
  1048.     char **envp;
  1049.     for (envp = environ; *envp; envp++)
  1050.       Vprocess_environment = Fcons (build_string (*envp),
  1051.                     Vprocess_environment);
  1052.   }
  1053.  
  1054.   /* jwz: don't do these things when in temacs (this used to be the case by
  1055.      virtue of egetenv() always returning 0, but that has been changed).
  1056.    */
  1057. #ifndef CANNOT_DUMP
  1058.   if (!initialized)
  1059.     {
  1060.       Vdata_directory = Qnil;
  1061.       Vdoc_directory = Qnil;
  1062.       Vexec_path = Qnil;
  1063.     }
  1064.   else
  1065. #endif
  1066.     {
  1067.       char *data_dir = egetenv ("EMACSDATA");
  1068.       char *doc_dir = egetenv ("EMACSDOC");
  1069.     
  1070. #ifdef PATH_DATA
  1071.       if (!data_dir)
  1072.     data_dir = (char *) PATH_DATA;
  1073. #endif
  1074. #ifdef PATH_DOC
  1075.       if (!doc_dir)
  1076.     doc_dir = (char *) PATH_DOC;
  1077. #endif
  1078.     
  1079.       if (data_dir)
  1080.     Vdata_directory = Ffile_name_as_directory
  1081.       (build_string (data_dir));
  1082.       else
  1083.     Vdata_directory = Qnil;
  1084.       if (doc_dir)
  1085.     Vdoc_directory = Ffile_name_as_directory
  1086.       (build_string (doc_dir));
  1087.       else
  1088.     Vdoc_directory = Qnil;
  1089.  
  1090.       /* Check the EMACSPATH environment variable, defaulting to the
  1091.      PATH_EXEC path from paths.h.  */
  1092.       Vexec_path = decode_env_path ("EMACSPATH",
  1093. #ifdef PATH_EXEC
  1094.                     PATH_EXEC
  1095. #else
  1096.                     0
  1097. #endif
  1098.                     );
  1099.     }
  1100.  
  1101.   if (NILP (Vexec_path))
  1102.     Vexec_directory = Qnil;
  1103.       else
  1104.     Vexec_directory = Ffile_name_as_directory
  1105.       (Fcar (Vexec_path));
  1106.  
  1107.   if (initialized)
  1108.     Vexec_path = nconc2 (decode_env_path ("PATH", 0),
  1109.                          Vexec_path);
  1110.  
  1111.   if (!NILP (Vexec_directory))
  1112.     {
  1113.       tempdir = Fdirectory_file_name (Vexec_directory);
  1114.       if (access ((char *) string_data (XSTRING (tempdir)), 0) < 0)
  1115.     {
  1116.       /* If the hard-coded path is bogus, fail silently.
  1117.          This will allow the normal heuristics to make an attempt. */
  1118. #if 0
  1119.       warn_when_safe
  1120.         (Qpath, Qwarning,
  1121.          "Warning: machine-dependent data dir (%s) does not exist.\n",
  1122.          string_data (XSTRING (Vexec_directory)));
  1123. #else
  1124.       Vexec_directory = Qnil;
  1125. #endif
  1126.     }
  1127.     }
  1128.  
  1129.   if (!NILP (Vdata_directory))
  1130.     {
  1131.       tempdir = Fdirectory_file_name (Vdata_directory);
  1132.       if (access ((char *) string_data (XSTRING (tempdir)), 0) < 0)
  1133.     {
  1134.       /* If the hard-coded path is bogus, fail silently.
  1135.          This will allow the normal heuristics to make an attempt. */
  1136. #if 0
  1137.       warn_when_safe
  1138.         (Qpath, Qwarning,
  1139.          "Warning: machine-independent data dir (%s) does not exist.\n",
  1140.          string_data (XSTRING (Vdata_directory)));
  1141. #else
  1142.       Vdata_directory = Qnil;
  1143. #endif
  1144.     }
  1145.     }
  1146.   
  1147. #ifdef VMS
  1148.   Vshell_file_name = build_string ("*dcl*");
  1149. #else /* not VMS */
  1150.   sh = (char *) egetenv ("SHELL");
  1151. #if defined(MSDOS) || defined(WIN32)
  1152.   if (!sh) sh = egetenv ("COMSPEC");
  1153.   {
  1154.     char *tem;
  1155.     if (sh)
  1156.       {
  1157.     tem = (char *) alloca (strlen (sh) + 1);
  1158.     sh = dostounix_filename (strcpy (tem, sh));
  1159.       }
  1160.   }
  1161. #ifdef WIN32
  1162.   Vshell_file_name = build_string (sh ? sh : "/winnt/system32/cmd.exe");
  1163. #else /* MSDOS */
  1164.   Vshell_file_name = build_string (sh ? sh : "/command.com");
  1165. #endif /* MSDOS */
  1166. #else /* not MSDOS and not WIN32  */
  1167.   Vshell_file_name = build_string (sh ? sh : "/bin/sh");
  1168. #endif /* not MSDOS and not WIN32  */
  1169. #endif /* not VMS */
  1170. }
  1171.  
  1172. #if 0
  1173. void
  1174. set_process_environment (void)
  1175. {
  1176.   REGISTER char **envp;
  1177.  
  1178.   Vprocess_environment = Qnil;
  1179. #ifndef CANNOT_DUMP
  1180.   if (initialized)
  1181. #endif
  1182.     for (envp = environ; *envp; envp++)
  1183.       Vprocess_environment = Fcons (build_string (*envp),
  1184.                     Vprocess_environment);
  1185. }
  1186. #endif /* unused */
  1187.  
  1188. void
  1189. syms_of_callproc (void)
  1190. {
  1191. #ifndef VMS
  1192.   defsubr (&Scall_process_internal);
  1193.   defsubr (&Sgetenv);
  1194. #endif
  1195. }
  1196.  
  1197. void
  1198. vars_of_callproc (void)
  1199. {
  1200.   /* This function can GC */
  1201. #ifdef MSDOS
  1202.   DEFVAR_LISP ("binary-process-input", &Vbinary_process_input,
  1203.     "*If non-nil then new subprocesses are assumed to take binary input.");
  1204.   Vbinary_process_input = Qnil;
  1205.  
  1206.   DEFVAR_LISP ("binary-process-output", &Vbinary_process_output,
  1207.     "*If non-nil then new subprocesses are assumed to produce binary output.");
  1208.   Vbinary_process_output = Qnil;
  1209. #endif
  1210.  
  1211.   DEFVAR_LISP ("shell-file-name", &Vshell_file_name,
  1212.     "*File name to load inferior shells from.\n\
  1213. Initialized from the SHELL environment variable.");
  1214.  
  1215.   DEFVAR_LISP ("exec-path", &Vexec_path,
  1216.     "*List of directories to search programs to run in subprocesses.\n\
  1217. Each element is a string (directory name) or nil (try default directory).");
  1218.  
  1219.   DEFVAR_LISP ("exec-directory", &Vexec_directory,
  1220.     "Directory of architecture-dependent files that come with XEmacs,\n\
  1221. especially executable programs intended for Emacs to invoke.");
  1222.  
  1223.   DEFVAR_LISP ("data-directory", &Vdata_directory,
  1224.     "Directory of architecture-independent files that come with XEmacs,\n\
  1225. intended for Emacs to use.");
  1226.  
  1227.   /* #### FSF puts the DOC file into data-directory.
  1228.      Argue with JWZ if you want to change this. */
  1229.   DEFVAR_LISP ("doc-directory", &Vdoc_directory,
  1230.     "Directory containing the DOC file that comes with XEmacs.\n\
  1231. This is usually the same as exec-directory.");
  1232.  
  1233.   DEFVAR_LISP ("process-environment", &Vprocess_environment,
  1234.     "List of environment variables for subprocesses to inherit.\n\
  1235. Each element should be a string of the form ENVVARNAME=VALUE.\n\
  1236. The environment which Emacs inherits is placed in this variable\n\
  1237. when Emacs starts.");
  1238. }
  1239.  
  1240. void
  1241. complex_vars_of_callproc (void)
  1242. {
  1243.   DEFVAR_LISP ("configure-info-directory", &Vconfigure_info_directory,
  1244.     "For internal use by the build procedure only.\n\
  1245. This is the name of the directory in which the build procedure installed\n\
  1246. Emacs's info files; the default value for Info-default-directory-list\n\
  1247. includes this.");
  1248. #ifdef PATH_INFO
  1249.   Vconfigure_info_directory =
  1250.     Ffile_name_as_directory (build_string (PATH_INFO));
  1251. #else
  1252.   Vconfigure_info_directory = Qnil;
  1253. #endif
  1254. }
  1255.