ghc/lib/std/System.lhs

   1 -- -----------------------------------------------------------------------------
   2 -- $Id: System.lhs,v 1.36 2001/10/13 16:02:47 sof Exp $
   3 --
   4 -- (c) The University of Glasgow, 1994-2000
   5 --
   6
   7 \begin{code}
   8 #include "config.h"
   9 module System
  10     (
  11       ExitCode(ExitSuccess,ExitFailure)
  12     , getArgs       -- :: IO [String]
  13     , getProgName   -- :: IO String
  14     , getEnv        -- :: String -> IO String
  15     , system        -- :: String -> IO ExitCode
  16     , exitWith      -- :: ExitCode -> IO a
  17     , exitFailure   -- :: IO a
  18   ) where
  19
  20 import Monad
  21 import Prelude
  22 import PrelCError
  23 import PrelCString
  24 import PrelCTypes
  25 import PrelMarshalArray
  26 import PrelMarshalAlloc
  27 import PrelPtr
  28 import PrelStorable
  29 import PrelIOBase
  30
  31 -- ---------------------------------------------------------------------------
  32 -- getArgs, getProgName, getEnv
  33
  34 -- Computation `getArgs' returns a list of the program's command
  35 -- line arguments (not including the program name).
  36
  37 getArgs :: IO [String]
  38 getArgs =
  39   alloca $ \ p_argc ->
  40   alloca $ \ p_argv -> do
  41    getProgArgv p_argc p_argv
  42    p    <- fromIntegral `liftM` peek p_argc
  43    argv <- peek p_argv
  44    peekArray (p - 1) (advancePtr argv 1) >>= mapM peekCString
  45
  46
  47 foreign import "getProgArgv" getProgArgv :: Ptr CInt -> Ptr (Ptr CString) -> IO ()
  48
  49 -- Computation `getProgName' returns the name of the program
  50 -- as it was invoked.
  51
  52 getProgName :: IO String
  53 getProgName =
  54   alloca $ \ p_argc ->
  55   alloca $ \ p_argv -> do
  56      getProgArgv p_argc p_argv
  57      argv <- peek p_argv
  58      unpackProgName argv
  59
  60 -- Computation `getEnv var' returns the value
  61 -- of the environment variable {\em var}.
  62
  63 -- This computation may fail with
  64 --    NoSuchThing: The environment variable does not exist.
  65
  66 getEnv :: String -> IO String
  67 getEnv name =
  68     withCString name $ \s -> do
  69       litstring <- _getenv s
  70       if litstring /= nullPtr
  71         then peekCString litstring
  72         else ioException (IOError Nothing NoSuchThing "getEnv"
  73                           "no environment variable" (Just name))
  74
  75 foreign import ccall "getenv" unsafe _getenv :: CString -> IO (Ptr CChar)
  76
  77 -- ---------------------------------------------------------------------------
  78 -- system
  79
  80 -- Computation `system cmd' returns the exit code
  81 -- produced when the operating system processes the command {\em cmd}.
  82
  83 -- This computation may fail with
  84 --   PermissionDenied
  85 --      The process has insufficient privileges to perform the operation.
  86 --   ResourceExhausted
  87 --      Insufficient resources are available to perform the operation.
  88 --   UnsupportedOperation
  89 --      The implementation does not support system calls.
  90
  91 system :: String -> IO ExitCode
  92 system "" = ioException (IOError Nothing InvalidArgument "system" "null command" Nothing)
  93 system cmd =
  94   withCString cmd $ \s -> do
  95     status <- throwErrnoIfMinus1 "system" (primSystem s)
  96     case status of
  97         0  -> return ExitSuccess
  98         n  -> return (ExitFailure n)
  99
 100 foreign import ccall "systemCmd" unsafe primSystem :: CString -> IO Int
 101
 102 -- ---------------------------------------------------------------------------
 103 -- exitWith
 104
 105 -- `exitWith code' terminates the program, returning `code' to the
 106 -- program's caller.  Before it terminates, any open or semi-closed
 107 -- handles are first closed.
 108
 109 exitWith :: ExitCode -> IO a
 110 exitWith ExitSuccess = throw (ExitException ExitSuccess)
 111 exitWith code@(ExitFailure n)
 112   | n == 0 = ioException (IOError Nothing InvalidArgument "exitWith" "ExitFailure 0" Nothing)
 113   | otherwise = throw (ExitException code)
 114
 115 exitFailure :: IO a
 116 exitFailure = exitWith (ExitFailure 1)
 117
 118 -- ---------------------------------------------------------------------------
 119 -- Local utilities
 120
 121 unpackProgName  :: Ptr (Ptr CChar) -> IO String   -- argv[0]
 122 unpackProgName argv = do
 123   s <- peekElemOff argv 0 >>= peekCString
 124   return (basename s)
 125   where
 126    basename :: String -> String
 127    basename f = go f f
 128     where
 129       go acc [] = acc
 130       go acc (x:xs)
 131         | isPathSeparator x = go xs xs
 132         | otherwise         = go acc xs
 133
 134    isPathSeparator :: Char -> Bool
 135    isPathSeparator '/'  = True
 136 #ifdef mingw32_TARGET_OS
 137    isPathSeparator '\\' = True
 138 #endif
 139    isPathSeparator _    = False
 140
 141 \end{code}