Internals.hs 21.1 KB
Newer Older
dterei's avatar
dterei committed
1
2
{-# LANGUAGE CPP #-}
{-# LANGUAGE ForeignFunctionInterface, RecordWildCards #-}
Ross Paterson's avatar
Ross Paterson committed
3
{-# OPTIONS_HADDOCK hide #-}
Ian Lynagh's avatar
Ian Lynagh committed
4
5
{-# OPTIONS_GHC -w #-}
-- XXX We get some warnings on Windows
6
7
8
#if __GLASGOW_HASKELL__ >= 701
{-# LANGUAGE Trustworthy #-}
#endif
Ian Lynagh's avatar
Ian Lynagh committed
9

10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
-----------------------------------------------------------------------------
-- |
-- Module      :  System.Process.Internals
-- Copyright   :  (c) The University of Glasgow 2004
-- License     :  BSD-style (see the file libraries/base/LICENSE)
-- 
-- Maintainer  :  libraries@haskell.org
-- Stability   :  experimental
-- Portability :  portable
--
-- Operations for creating and interacting with sub-processes.
--
-----------------------------------------------------------------------------

-- #hide
module System.Process.Internals (
26
#ifndef __HUGS__
27
28
29
	ProcessHandle(..), ProcessHandle__(..), 
	PHANDLE, closePHANDLE, mkProcessHandle, 
	withProcessHandle, withProcessHandle_,
Simon Marlow's avatar
Simon Marlow committed
30
31
32
33
34
#ifdef __GLASGOW_HASKELL__
        CreateProcess(..),
        CmdSpec(..), StdStream(..),
	runGenProcess_,
#endif
35
#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)
36
	 pPrPr_disableITimers, c_execvpe,
ross's avatar
ross committed
37
	ignoreSignal, defaultSignal,
38
#endif
39
#endif
Simon Marlow's avatar
Simon Marlow committed
40
	withFilePathException, withCEnvironment,
41
	translate,
Simon Marlow's avatar
Simon Marlow committed
42

43
#ifndef __HUGS__
Simon Marlow's avatar
Simon Marlow committed
44
        fdToHandle,
45
#endif
46
47
  ) where

48
#ifndef __HUGS__
49
#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)
50
import System.Posix.Types ( CPid )
Ian Lynagh's avatar
Ian Lynagh committed
51
import System.Posix.Process.Internals ( pPrPr_disableITimers, c_execvpe )
Simon Marlow's avatar
Simon Marlow committed
52
import System.IO 	( IOMode(..) )
53
54
#else
import Data.Word ( Word32 )
55
import Data.IORef
56
#endif
57
#endif
58

Simon Marlow's avatar
Simon Marlow committed
59
import System.IO 	( Handle )
60
import System.Exit	( ExitCode )
Simon Marlow's avatar
Simon Marlow committed
61
import Control.Concurrent
62
import Control.Exception
Simon Marlow's avatar
Simon Marlow committed
63
64
65
import Foreign.C
import Foreign

ross's avatar
ross committed
66
# ifdef __GLASGOW_HASKELL__
Simon Marlow's avatar
Simon Marlow committed
67

Simon Marlow's avatar
Simon Marlow committed
68
import System.Posix.Internals
Simon Marlow's avatar
Simon Marlow committed
69
70
71
72
73
74
75
76
77
78
79
80
81
#if __GLASGOW_HASKELL__ >= 611
import GHC.IO.Exception
import GHC.IO.Encoding
import qualified GHC.IO.FD as FD
import GHC.IO.Device
import GHC.IO.Handle
import GHC.IO.Handle.FD
import GHC.IO.Handle.Internals
import GHC.IO.Handle.Types
import System.IO.Error
import Data.Typeable
#if defined(mingw32_HOST_OS)
import GHC.IO.IOMode
82
import System.Win32.DebugApi (PHANDLE)
Simon Marlow's avatar
Simon Marlow committed
83
84
#endif
#else
85
import GHC.IOBase	( haFD, FD, IOException(..) )
Simon Marlow's avatar
Simon Marlow committed
86
import GHC.Handle
Simon Marlow's avatar
Simon Marlow committed
87
88
#endif

ross's avatar
ross committed
89
# elif __HUGS__
Simon Marlow's avatar
Simon Marlow committed
90

Ross Paterson's avatar
Ross Paterson committed
91
import Hugs.Exception	( IOException(..) )
Simon Marlow's avatar
Simon Marlow committed
92

ross's avatar
ross committed
93
# endif
94

Ian Lynagh's avatar
Ian Lynagh committed
95
96
97
#ifdef base4
import System.IO.Error		( ioeSetFileName )
#endif
98
99
100
101
102
103
#if defined(mingw32_HOST_OS)
import Control.Monad		( when )
import System.Directory		( doesFileExist )
import System.IO.Error		( isDoesNotExistError, doesNotExistErrorType,
				  mkIOError )
import System.Environment	( getEnv )
104
import System.FilePath
105
106
#endif

107
#ifdef __HUGS__
ross's avatar
ross committed
108
{-# CFILES cbits/execvpe.c  #-}
109
#endif
110

111
#include "HsProcessConfig.h"
112
#include "processFlags.h"
113

114
#ifndef __HUGS__
115
116
117
118
119
120
121
122
123
124
-- ----------------------------------------------------------------------------
-- ProcessHandle type

{- | A handle to a process, which can be used to wait for termination
     of the process using 'waitForProcess'.

     None of the process-creation functions in this library wait for
     termination: they all return a 'ProcessHandle' which may be used
     to wait for the process later.
-}
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
data ProcessHandle__ = OpenHandle PHANDLE | ClosedHandle ExitCode
newtype ProcessHandle = ProcessHandle (MVar ProcessHandle__)

withProcessHandle
	:: ProcessHandle 
	-> (ProcessHandle__ -> IO (ProcessHandle__, a))
	-> IO a
withProcessHandle (ProcessHandle m) io = modifyMVar m io

withProcessHandle_
	:: ProcessHandle 
	-> (ProcessHandle__ -> IO ProcessHandle__)
	-> IO ()
withProcessHandle_ (ProcessHandle m) io = modifyMVar_ m io

140
#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)
141

142
type PHANDLE = CPid
143

144
145
146
throwErrnoIfBadPHandle :: String -> IO PHANDLE -> IO PHANDLE  
throwErrnoIfBadPHandle = throwErrnoIfMinus1

147
mkProcessHandle :: PHANDLE -> IO ProcessHandle
148
149
150
151
152
153
mkProcessHandle p = do
  m <- newMVar (OpenHandle p)
  return (ProcessHandle m)

closePHANDLE :: PHANDLE -> IO ()
closePHANDLE _ = return ()
154

155
#else
156

157
158
throwErrnoIfBadPHandle :: String -> IO PHANDLE -> IO PHANDLE  
throwErrnoIfBadPHandle = throwErrnoIfNull
159
160
161
162
163
164

-- On Windows, we have to close this HANDLE when it is no longer required,
-- hence we add a finalizer to it, using an IORef as the box on which to
-- attach the finalizer.
mkProcessHandle :: PHANDLE -> IO ProcessHandle
mkProcessHandle h = do
165
166
167
168
169
170
171
172
173
174
175
176
177
   m <- newMVar (OpenHandle h)
   addMVarFinalizer m (processHandleFinaliser m)
   return (ProcessHandle m)

processHandleFinaliser m =
   modifyMVar_ m $ \p_ -> do 
	case p_ of
	  OpenHandle ph -> closePHANDLE ph
	  _ -> return ()
	return (error "closed process handle")

closePHANDLE :: PHANDLE -> IO ()
closePHANDLE ph = c_CloseHandle ph
178
179
180
181
182

foreign import stdcall unsafe "CloseHandle"
  c_CloseHandle
	:: PHANDLE
	-> IO ()
183
#endif
184
#endif /* !__HUGS__ */
185

186
187
-- ----------------------------------------------------------------------------

Simon Marlow's avatar
Simon Marlow committed
188
data CreateProcess = CreateProcess{
189
190
191
192
193
194
195
196
  cmdspec      :: CmdSpec,                 -- ^ Executable & arguments, or shell command
  cwd          :: Maybe FilePath,          -- ^ Optional path to the working directory for the new process
  env          :: Maybe [(String,String)], -- ^ Optional environment (otherwise inherit from the current process)
  std_in       :: StdStream,               -- ^ How to determine stdin
  std_out      :: StdStream,               -- ^ How to determine stdout
  std_err      :: StdStream,               -- ^ How to determine stderr
  close_fds    :: Bool,                    -- ^ Close all file descriptors except stdin, stdout and stderr in the new process (on Windows, only works if std_in, std_out, and std_err are all Inherit)
  create_group :: Bool                     -- ^ Create a new process group
Simon Marlow's avatar
Simon Marlow committed
197
198
199
200
201
202
203
204
205
 }

data CmdSpec 
  = ShellCommand String            
      -- ^ a command line to execute using the shell
  | RawCommand FilePath [String]
      -- ^ the filename of an executable with a list of arguments

data StdStream
206
207
208
209
210
211
  = Inherit                  -- ^ Inherit Handle from parent
  | UseHandle Handle         -- ^ Use the supplied Handle
  | CreatePipe               -- ^ Create a new pipe.  The returned
                             -- @Handle@ will use the default encoding
                             -- and newline translation mode (just
                             -- like @Handle@s created by @openFile@).
Simon Marlow's avatar
Simon Marlow committed
212
213
214
215
216
217
218
219

runGenProcess_
  :: String                     -- ^ function name (for error messages)
  -> CreateProcess
  -> Maybe CLong		-- ^ handler for SIGINT
  -> Maybe CLong		-- ^ handler for SIGQUIT
  -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)

220
#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)
221

ross's avatar
ross committed
222
#ifdef __GLASGOW_HASKELL__
Simon Marlow's avatar
Simon Marlow committed
223

224
225
226
-- -----------------------------------------------------------------------------
-- POSIX runProcess with signal handling in the child

Simon Marlow's avatar
Simon Marlow committed
227
228
229
230
231
232
runGenProcess_ fun CreateProcess{ cmdspec = cmdsp,
                                  cwd = mb_cwd,
                                  env = mb_env,
                                  std_in = mb_stdin,
                                  std_out = mb_stdout,
                                  std_err = mb_stderr,
hamish's avatar
hamish committed
233
                                  close_fds = mb_close_fds,
234
                                  create_group = mb_create_group }
Simon Marlow's avatar
Simon Marlow committed
235
236
237
238
239
240
241
242
               mb_sigint mb_sigquit
 = do
  let (cmd,args) = commandToProcess cmdsp
  withFilePathException cmd $
   alloca $ \ pfdStdInput  ->
   alloca $ \ pfdStdOutput ->
   alloca $ \ pfdStdError  ->
   maybeWith withCEnvironment mb_env $ \pEnv ->
243
244
   maybeWith withFilePath mb_cwd $ \pWorkDir ->
   withMany withFilePath (cmd:args) $ \cstrs ->
Simon Marlow's avatar
Simon Marlow committed
245
246
247
248
249
250
   withArray0 nullPtr cstrs $ \pargs -> do
     
     fdin  <- mbFd fun fd_stdin  mb_stdin
     fdout <- mbFd fun fd_stdout mb_stdout
     fderr <- mbFd fun fd_stderr mb_stderr

251
252
253
254
255
256
257
258
     let (set_int, inthand) 
		= case mb_sigint of
			Nothing   -> (0, 0)
			Just hand -> (1, hand)
	 (set_quit, quithand) 
		= case mb_sigquit of
			Nothing   -> (0, 0)
			Just hand -> (1, hand)
Simon Marlow's avatar
Simon Marlow committed
259

260
261
262
263
264
265
     -- runInteractiveProcess() blocks signals around the fork().
     -- Since blocking/unblocking of signals is a global state
     -- operation, we better ensure mutual exclusion of calls to
     -- runInteractiveProcess().
     proc_handle <- withMVar runInteractiveProcess_lock $ \_ ->
                    throwErrnoIfMinus1 fun $
Simon Marlow's avatar
Simon Marlow committed
266
267
268
269
	                 c_runInteractiveProcess pargs pWorkDir pEnv 
                                fdin fdout fderr
				pfdStdInput pfdStdOutput pfdStdError
			        set_int inthand set_quit quithand
270
271
                                ((if mb_close_fds then RUN_PROCESS_IN_CLOSE_FDS else 0)
                                .|.(if mb_create_group then RUN_PROCESS_IN_NEW_GROUP else 0))
Simon Marlow's avatar
Simon Marlow committed
272
273
274
275
276
277
278
279

     hndStdInput  <- mbPipe mb_stdin  pfdStdInput  WriteMode
     hndStdOutput <- mbPipe mb_stdout pfdStdOutput ReadMode
     hndStdError  <- mbPipe mb_stderr pfdStdError  ReadMode

     ph <- mkProcessHandle proc_handle
     return (hndStdInput, hndStdOutput, hndStdError, ph)

280
281
282
283
{-# NOINLINE runInteractiveProcess_lock #-}
runInteractiveProcess_lock :: MVar ()
runInteractiveProcess_lock = unsafePerformIO $ newMVar ()

Simon Marlow's avatar
Simon Marlow committed
284
285
286
287
288
289
290
291
292
293
294
foreign import ccall unsafe "runInteractiveProcess" 
  c_runInteractiveProcess
        ::  Ptr CString
	-> CString
        -> Ptr CString
        -> FD
        -> FD
        -> FD
        -> Ptr FD
        -> Ptr FD
        -> Ptr FD
295
296
297
298
	-> CInt				-- non-zero: set child's SIGINT handler
	-> CLong			-- SIGINT handler
	-> CInt				-- non-zero: set child's SIGQUIT handler
	-> CLong			-- SIGQUIT handler
hamish's avatar
hamish committed
299
        -> CInt                         -- flags
300
301
        -> IO PHANDLE

ross's avatar
ross committed
302
303
#endif /* __GLASGOW_HASKELL__ */

Simon Marlow's avatar
Simon Marlow committed
304
305
306
ignoreSignal, defaultSignal :: CLong
ignoreSignal  = CONST_SIG_IGN
defaultSignal = CONST_SIG_DFL
ross's avatar
ross committed
307

308
309
310
311
#else

#ifdef __GLASGOW_HASKELL__

Simon Marlow's avatar
Simon Marlow committed
312
313
314
315
316
317
runGenProcess_ fun CreateProcess{ cmdspec = cmdsp,
                                  cwd = mb_cwd,
                                  env = mb_env,
                                  std_in = mb_stdin,
                                  std_out = mb_stdout,
                                  std_err = mb_stderr,
hamish's avatar
hamish committed
318
                                  close_fds = mb_close_fds,
319
                                  create_group = mb_create_group }
Simon Marlow's avatar
Simon Marlow committed
320
321
322
323
324
325
326
327
               _ignored_mb_sigint _ignored_mb_sigquit
 = do
  (cmd, cmdline) <- commandToProcess cmdsp
  withFilePathException cmd $
   alloca $ \ pfdStdInput  ->
   alloca $ \ pfdStdOutput ->
   alloca $ \ pfdStdError  ->
   maybeWith withCEnvironment mb_env $ \pEnv ->
328
329
   maybeWith withCWString mb_cwd $ \pWorkDir -> do
   withCWString cmdline $ \pcmdline -> do
Simon Marlow's avatar
Simon Marlow committed
330
331
332
333
334
     
     fdin  <- mbFd fun fd_stdin  mb_stdin
     fdout <- mbFd fun fd_stdout mb_stdout
     fderr <- mbFd fun fd_stderr mb_stderr

335
336
337
338
339
340
341
342
343
344
345
     -- #2650: we must ensure mutual exclusion of c_runInteractiveProcess,
     -- because otherwise there is a race condition whereby one thread
     -- has created some pipes, and another thread spawns a process which
     -- accidentally inherits some of the pipe handles that the first
     -- thread has created.
     -- 
     -- An MVar in Haskell is the best way to do this, because there
     -- is no way to do one-time thread-safe initialisation of a mutex
     -- the C code.  Also the MVar will be cheaper when not running
     -- the threaded RTS.
     proc_handle <- withMVar runInteractiveProcess_lock $ \_ ->
346
                    throwErrnoIfBadPHandle fun $
Simon Marlow's avatar
Simon Marlow committed
347
348
349
	                 c_runInteractiveProcess pcmdline pWorkDir pEnv 
                                fdin fdout fderr
				pfdStdInput pfdStdOutput pfdStdError
350
351
                                ((if mb_close_fds then RUN_PROCESS_IN_CLOSE_FDS else 0)
                                .|.(if mb_create_group then RUN_PROCESS_IN_NEW_GROUP else 0))
Simon Marlow's avatar
Simon Marlow committed
352
353
354
355
356
357
358
359

     hndStdInput  <- mbPipe mb_stdin  pfdStdInput  WriteMode
     hndStdOutput <- mbPipe mb_stdout pfdStdOutput ReadMode
     hndStdError  <- mbPipe mb_stderr pfdStdError  ReadMode

     ph <- mkProcessHandle proc_handle
     return (hndStdInput, hndStdOutput, hndStdError, ph)

360
361
362
{-# NOINLINE runInteractiveProcess_lock #-}
runInteractiveProcess_lock :: MVar ()
runInteractiveProcess_lock = unsafePerformIO $ newMVar ()
Simon Marlow's avatar
Simon Marlow committed
363

364
foreign import ccall unsafe "runInteractiveProcess"
Simon Marlow's avatar
Simon Marlow committed
365
  c_runInteractiveProcess
366
367
        :: CWString
        -> CWString
368
        -> Ptr CWString
369
370
371
        -> FD
        -> FD
        -> FD
Simon Marlow's avatar
Simon Marlow committed
372
373
374
        -> Ptr FD
        -> Ptr FD
        -> Ptr FD
hamish's avatar
hamish committed
375
        -> CInt                         -- flags
376
        -> IO PHANDLE
377
#endif
378
379
380

#endif /* __GLASGOW_HASKELL__ */

Simon Marlow's avatar
Simon Marlow committed
381
382
383
384
385
386
387
fd_stdin, fd_stdout, fd_stderr :: FD
fd_stdin  = 0
fd_stdout = 1
fd_stderr = 2

mbFd :: String -> FD -> StdStream -> IO FD
mbFd _   _std CreatePipe      = return (-1)
Simon Marlow's avatar
Simon Marlow committed
388
389
390
391
392
mbFd _fun std Inherit         = return std
mbFd fun _std (UseHandle hdl) = 
#if __GLASGOW_HASKELL__ < 611
  withHandle_ fun hdl $ return . haFD
#else
393
  withHandle fun hdl $ \h@Handle__{haDevice=dev,..} ->
Simon Marlow's avatar
Simon Marlow committed
394
    case cast dev of
395
396
397
398
399
400
      Just fd -> do
         -- clear the O_NONBLOCK flag on this FD, if it is set, since
         -- we're exposing it externally (see #3316)
         fd <- FD.setNonBlockingMode fd False
         return (Handle__{haDevice=fd,..}, FD.fdFD fd)
      Nothing ->
Simon Marlow's avatar
Simon Marlow committed
401
402
403
404
          ioError (mkIOError illegalOperationErrorType
		      "createProcess" (Just hdl) Nothing
                   `ioeSetErrorString` "handle is not a file descriptor")
#endif
Simon Marlow's avatar
Simon Marlow committed
405
406

mbPipe :: StdStream -> Ptr FD -> IOMode -> IO (Maybe Handle)
407
mbPipe CreatePipe pfd  mode = fmap Just (pfdToHandle pfd mode)
Simon Marlow's avatar
Simon Marlow committed
408
409
410
411
412
mbPipe _std      _pfd _mode = return Nothing

pfdToHandle :: Ptr FD -> IOMode -> IO Handle
pfdToHandle pfd mode = do
  fd <- peek pfd
Simon Marlow's avatar
Simon Marlow committed
413
414
415
416
417
418
  let filepath = "fd:" ++ show fd
#if __GLASGOW_HASKELL__ >= 611
  (fD,fd_type) <- FD.mkFD (fromIntegral fd) mode 
                       (Just (Stream,0,0)) -- avoid calling fstat()
                       False {-is_socket-}
                       False {-non-blocking-}
419
  fD <- FD.setNonBlockingMode fD True -- see #3316
Simon Marlow's avatar
Simon Marlow committed
420
421
422
  mkHandleFromFD fD fd_type filepath mode False{-is_socket-}
                       (Just localeEncoding)
#else
Simon Marlow's avatar
Simon Marlow committed
423
424
  fdToHandle' fd (Just Stream)
     False{-Windows: not a socket,  Unix: don't set non-blocking-}
Simon Marlow's avatar
Simon Marlow committed
425
426
     filepath mode True{-binary-}
#endif
Simon Marlow's avatar
Simon Marlow committed
427

ross's avatar
ross committed
428
#ifndef __HUGS__
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
-- ----------------------------------------------------------------------------
-- commandToProcess

{- | Turns a shell command into a raw command.  Usually this involves
     wrapping it in an invocation of the shell.

   There's a difference in the signature of commandToProcess between
   the Windows and Unix versions.  On Unix, exec takes a list of strings,
   and we want to pass our command to /bin/sh as a single argument.  

   On Windows, CreateProcess takes a single string for the command,
   which is later decomposed by cmd.exe.  In this case, we just want
   to prepend @\"c:\WINDOWS\CMD.EXE \/c\"@ to our command line.  The
   command-line translation that we normally do for arguments on
   Windows isn't required (or desirable) here.
-}

#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)

Simon Marlow's avatar
Simon Marlow committed
448
449
450
commandToProcess :: CmdSpec -> (FilePath, [String])
commandToProcess (ShellCommand string) = ("/bin/sh", ["-c", string])
commandToProcess (RawCommand cmd args) = (cmd, args)
451
452
453
454

#else

commandToProcess
Simon Marlow's avatar
Simon Marlow committed
455
456
457
  :: CmdSpec
  -> IO (FilePath, String)
commandToProcess (ShellCommand string) = do
458
  cmd <- findCommandInterpreter
Simon Marlow's avatar
Simon Marlow committed
459
  return (cmd, translate cmd ++ "/c " ++ string)
460
461
462
463
464
	-- We don't want to put the cmd into a single
	-- argument, because cmd.exe will not try to split it up.  Instead,
	-- we just tack the command on the end of the cmd.exe command line,
	-- which partly works.  There seem to be some quoting issues, but
	-- I don't have the energy to find+fix them right now (ToDo). --SDM
465
	-- (later) Now I don't know what the above comment means.  sigh.
Simon Marlow's avatar
Simon Marlow committed
466
467
commandToProcess (RawCommand cmd args) = do
  return (cmd, translate cmd ++ concatMap ((' ':) . translate) args)
468
469
470
471
472
473

-- Find CMD.EXE (or COMMAND.COM on Win98).  We use the same algorithm as
-- system() in the VC++ CRT (Vc7/crt/src/system.c in a VC++ installation).
findCommandInterpreter :: IO FilePath
findCommandInterpreter = do
  -- try COMSPEC first
Simon Marlow's avatar
Simon Marlow committed
474
475
476
477
478
#ifdef base3
  catchJust (\e -> case e of 
                     IOException e | isDoesNotExistError e -> Just e
                     _otherwise -> Nothing)
#else
Ross Paterson's avatar
Ross Paterson committed
479
  catchJust (\e -> if isDoesNotExistError e then Just e else Nothing)
Simon Marlow's avatar
Simon Marlow committed
480
#endif
Ross Paterson's avatar
Ross Paterson committed
481
            (getEnv "COMSPEC") $ \e -> do
482
483

    -- try to find CMD.EXE or COMMAND.COM
484
485
486
    {-
    XXX We used to look at _osver (using cbits) and pick which shell to
    use with
487
    let filename | osver .&. 0x8000 /= 0 = "command.com"
488
489
490
491
                 | otherwise             = "cmd.exe"
    We ought to use GetVersionEx instead, but for now we just look for
    either filename
    -}
492
493
494
495
496
497
498
    path <- getEnv "PATH"
    let
	-- use our own version of System.Directory.findExecutable, because
	-- that assumes the .exe suffix.
	search :: [FilePath] -> IO (Maybe FilePath)
	search [] = return Nothing
	search (d:ds) = do
499
500
		let path1 = d </> "cmd.exe"
		    path2 = d </> "command.com"
501
502
503
504
505
		b1 <- doesFileExist path1
		b2 <- doesFileExist path2
		if b1 then return (Just path1)
		      else if b2 then return (Just path2)
		                 else search ds
506
    --
507
    mb_path <- search (splitSearchPath path)
508
509
510
511
512

    case mb_path of
      Nothing -> ioError (mkIOError doesNotExistErrorType 
				"findCommandInterpreter" Nothing Nothing)
      Just cmd -> return cmd
513
514
#endif

ross's avatar
ross committed
515
516
#endif /* __HUGS__ */

517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
-- ------------------------------------------------------------------------
-- Escaping commands for shells

{-
On Windows we also use this for running commands.  We use CreateProcess,
passing a single command-line string (lpCommandLine) as its argument.
(CreateProcess is well documented on http://msdn.microsoft.com.)

      - It parses the beginning of the string to find the command. If the
        file name has embedded spaces, it must be quoted, using double
        quotes thus
                "foo\this that\cmd" arg1 arg2

      - The invoked command can in turn access the entire lpCommandLine string,
        and the C runtime does indeed do so, parsing it to generate the
        traditional argument vector argv[0], argv[1], etc.  It does this
        using a complex and arcane set of rules which are described here:

           http://msdn.microsoft.com/library/default.asp?url=/library/en-us/vccelng/htm/progs_12.asp

        (if this URL stops working, you might be able to find it by
        searching for "Parsing C Command-Line Arguments" on MSDN.  Also,
        the code in the Microsoft C runtime that does this translation
        is shipped with VC++).

Our goal in runProcess is to take a command filename and list of
arguments, and construct a string which inverts the translatsions
described above, such that the program at the other end sees exactly
the same arguments in its argv[] that we passed to rawSystem.

This inverse translation is implemented by 'translate' below.

Here are some pages that give informations on Windows-related
limitations and deviations from Unix conventions:

    http://support.microsoft.com/default.aspx?scid=kb;en-us;830473
    Command lines and environment variables effectively limited to 8191
    characters on Win XP, 2047 on NT/2000 (probably even less on Win 9x):

    http://www.microsoft.com/windowsxp/home/using/productdoc/en/default.asp?url=/WINDOWSXP/home/using/productdoc/en/percent.asp
    Command-line substitution under Windows XP. IIRC these facilities (or at
    least a large subset of them) are available on Win NT and 2000. Some
    might be available on Win 9x.

    http://www.microsoft.com/windowsxp/home/using/productdoc/en/default.asp?url=/WINDOWSXP/home/using/productdoc/en/Cmd.asp
    How CMD.EXE processes command lines.


Note: CreateProcess does have a separate argument (lpApplicationName)
with which you can specify the command, but we have to slap the
command into lpCommandLine anyway, so that argv[0] is what a C program
expects (namely the application name).  So it seems simpler to just
use lpCommandLine alone, which CreateProcess supports.
-}

translate :: String -> String
#if mingw32_HOST_OS
translate str = '"' : snd (foldr escape (True,"\"") str)
  where escape '"'  (b,     str) = (True,  '\\' : '"'  : str)
        escape '\\' (True,  str) = (True,  '\\' : '\\' : str)
        escape '\\' (False, str) = (False, '\\' : str)
        escape c    (b,     str) = (False, c : str)
        -- See long comment above for what this function is trying to do.
        --
        -- The Bool passed back along the string is True iff the
        -- rest of the string is a sequence of backslashes followed by
        -- a double quote.
#else
translate str = '\'' : foldr escape "'" str
  where escape '\'' = showString "'\\''"
        escape c    = showChar c
#endif

590
591
592
593
594
595
-- ----------------------------------------------------------------------------
-- Utils

withFilePathException :: FilePath -> IO a -> IO a
withFilePathException fpath act = handle mapEx act
  where
Simon Marlow's avatar
Simon Marlow committed
596
#ifdef base4
Ian Lynagh's avatar
Ian Lynagh committed
597
    mapEx ex = ioError (ioeSetFileName ex fpath)
598
599
600
#else
    mapEx (IOException (IOError h iot fun str _)) = ioError (IOError h iot fun str (Just fpath))
#endif
601
602
603

#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)
withCEnvironment :: [(String,String)] -> (Ptr CString  -> IO a) -> IO a
Simon Marlow's avatar
Simon Marlow committed
604
605
withCEnvironment envir act =
  let env' = map (\(name, val) -> name ++ ('=':val)) envir 
606
607
  in withMany withCString env' (\pEnv -> withArray0 nullPtr pEnv act)
#else
608
withCEnvironment :: [(String,String)] -> (Ptr CWString -> IO a) -> IO a
Simon Marlow's avatar
Simon Marlow committed
609
610
withCEnvironment envir act =
  let env' = foldr (\(name, val) env -> name ++ ('=':val)++'\0':env) "\0" envir
611
  in withCWString env' (act . castPtr)
612
613
#endif