ghc/lib/std/System.lhs

   1 -- -----------------------------------------------------------------------------
   2 -- $Id: System.lhs,v 1.37 2001/11/08 16:36:39 simonmar 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" unsafe
  48   getProgArgv :: Ptr CInt -> Ptr (Ptr CString) -> IO ()
  49
  50 -- Computation `getProgName' returns the name of the program
  51 -- as it was invoked.
  52
  53 getProgName :: IO String
  54 getProgName =
  55   alloca $ \ p_argc ->
  56   alloca $ \ p_argv -> do
  57      getProgArgv p_argc p_argv
  58      argv <- peek p_argv
  59      unpackProgName argv
  60
  61 -- Computation `getEnv var' returns the value
  62 -- of the environment variable {\em var}.
  63
  64 -- This computation may fail with
  65 --    NoSuchThing: The environment variable does not exist.
  66
  67 getEnv :: String -> IO String
  68 getEnv name =
  69     withCString name $ \s -> do
  70       litstring <- _getenv s
  71       if litstring /= nullPtr
  72         then peekCString litstring
  73         else ioException (IOError Nothing NoSuchThing "getEnv"
  74                           "no environment variable" (Just name))
  75
  76 foreign import ccall "getenv" unsafe _getenv :: CString -> IO (Ptr CChar)
  77
  78 -- ---------------------------------------------------------------------------
  79 -- system
  80
  81 -- Computation `system cmd' returns the exit code
  82 -- produced when the operating system processes the command {\em cmd}.
  83
  84 -- This computation may fail with
  85 --   PermissionDenied
  86 --      The process has insufficient privileges to perform the operation.
  87 --   ResourceExhausted
  88 --      Insufficient resources are available to perform the operation.
  89 --   UnsupportedOperation
  90 --      The implementation does not support system calls.
  91
  92 system :: String -> IO ExitCode
  93 system "" = ioException (IOError Nothing InvalidArgument "system" "null command" Nothing)
  94 system cmd =
  95   withCString cmd $ \s -> do
  96     status <- throwErrnoIfMinus1 "system" (primSystem s)
  97     case status of
  98         0  -> return ExitSuccess
  99         n  -> return (ExitFailure n)
 100
 101 foreign import ccall "systemCmd" unsafe primSystem :: CString -> IO Int
 102
 103 -- ---------------------------------------------------------------------------
 104 -- exitWith
 105
 106 -- `exitWith code' terminates the program, returning `code' to the
 107 -- program's caller.  Before it terminates, any open or semi-closed
 108 -- handles are first closed.
 109
 110 exitWith :: ExitCode -> IO a
 111 exitWith ExitSuccess = throw (ExitException ExitSuccess)
 112 exitWith code@(ExitFailure n)
 113   | n == 0 = ioException (IOError Nothing InvalidArgument "exitWith" "ExitFailure 0" Nothing)
 114   | otherwise = throw (ExitException code)
 115
 116 exitFailure :: IO a
 117 exitFailure = exitWith (ExitFailure 1)
 118
 119 -- ---------------------------------------------------------------------------
 120 -- Local utilities
 121
 122 unpackProgName  :: Ptr (Ptr CChar) -> IO String   -- argv[0]
 123 unpackProgName argv = do
 124   s <- peekElemOff argv 0 >>= peekCString
 125   return (basename s)
 126   where
 127    basename :: String -> String
 128    basename f = go f f
 129     where
 130       go acc [] = acc
 131       go acc (x:xs)
 132         | isPathSeparator x = go xs xs
 133         | otherwise         = go acc xs
 134
 135    isPathSeparator :: Char -> Bool
 136    isPathSeparator '/'  = True
 137 #ifdef mingw32_TARGET_OS
 138    isPathSeparator '\\' = True
 139 #endif
 140    isPathSeparator _    = False
 141
 142 \end{code}