diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,32 @@ +http://creativecommons.org/licenses/publicdomain/ +------------------------------------------------- + +Copyright-Only Dedication (based on United States law) or +Public Domain Certification + +The person or persons who have associated work with this document (the +"Dedicator" or "Certifier") hereby either (a) certifies that, to the best of +his knowledge, the work of authorship identified is in the public domain +of the country from which the work is published, or (b) hereby dedicates +whatever copyright the dedicators holds in the work of authorship identified +below (the "Work") to the public domain. A certifier, moreover, dedicates any +copyright interest he may have in the associated work, and for these purposes, +is described as a "dedicator" below. + +A certifier has taken reasonable steps to verify the copyright status of this +work. Certifier recognizes that his good faith efforts may not shield him +from liability if in fact the work certified is not in the public domain. + +Dedicator makes this dedication for the benefit of the public at large and +to the detriment of the Dedicator's heirs and successors. Dedicator intends +this dedication to be an overt act of relinquishment in perpetuity of all +present and future rights under copyright law, whether vested or contingent, +in the Work. Dedicator understands that such relinquishment of all rights +includes the relinquishment of all rights to enforce (by lawsuit or otherwise) +those copyrights in the Work. + +Dedicator recognizes that, once placed in the public domain, the Work may +be freely reproduced, distributed, transmitted, used, modified, built upon, +or otherwise exploited by anyone for any purpose, commercial or non-commercial, +and in any way, including by methods that have not yet been invented or +conceived. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,4 @@ +#! /usr/bin/env runhaskell + +> import Distribution.Simple +> main = defaultMain diff --git a/System/Environment/Executable.hs b/System/Environment/Executable.hs new file mode 100644 --- /dev/null +++ b/System/Environment/Executable.hs @@ -0,0 +1,100 @@ + +{- | + +The documentation of "System.Environment.getProgName" says that + +\"However, this is hard-to-impossible to implement on some non-Unix OSes, +so instead, for maximum portability, we just return the leafname +of the program as invoked. Even then there are some differences +between platforms: on Windows, for example, a program invoked as +foo is probably really FOO.EXE, and that is what "getProgName" will +return.\" + +This library tries to fix this issue. +It also provides some platform-specific functions (most notably getting +the path of the application bundle on OSX). Supported operating +systems: + + * Win32 (tested on Windows XP \/ x86 only) + + * Mac OS X (tested on Leopard \/ x86 only) + + * Linux + + * \*BSD (untested) + + * Solaris (untested, and probably works on Solaris 10 only) + +-} + +{-# LANGUAGE CPP #-} + +module System.Environment.Executable + ( getExecutablePath + , splitExecutablePath + +#ifdef mingw32_HOST_OS + , getModulePath +#endif + +#ifdef darwin_HOST_OS + , getApplicationBundlePath +#endif + + ) + where + +import Control.Monad (liftM) +import System.FilePath (splitFileName) + +-------------------------------------------------------------------------------- + +#ifdef mingw32_HOST_OS +#define SUPPORTED_OS +import System.Environment.Executable.Win32 +#endif + +#ifdef darwin_HOST_OS +#define SUPPORTED_OS +import System.Environment.Executable.MacOSX +#endif + +#ifdef linux_HOST_OS +#define SUPPORTED_OS +import System.Environment.Executable.Linux +#endif + +#ifdef freebsd_HOST_OS +#define SUPPORTED_OS +import System.Environment.Executable.BSD +#endif + +#ifdef netbsd_HOST_OS +#define SUPPORTED_OS +import System.Environment.Executable.BSD +#endif + +#ifdef openbsd_HOST_OS +#define SUPPORTED_OS +import System.Environment.Executable.BSD +#endif + +#ifdef solaris_HOST_OS +#define SUPPORTED_OS +import System.Environment.Executable.Solaris +#endif + +-------------------------------------------------------------------------------- + +splitExecutablePath :: IO (FilePath,FilePath) +splitExecutablePath = liftM splitFileName getExecutablePath + +-------------------------------------------------------------------------------- + +#ifndef SUPPORTED_OS +{-# WARNING getExecutablePath "the host OS is not supported!" #-} +getExecutablePath :: IO String +getExecutablePath = error "host OS not supported" +#endif + +-------------------------------------------------------------------------------- diff --git a/System/Environment/Executable/BSD.hs b/System/Environment/Executable/BSD.hs new file mode 100644 --- /dev/null +++ b/System/Environment/Executable/BSD.hs @@ -0,0 +1,51 @@ + + +{- +symbolic links to the executable: + +Linux: +/proc//exe + +Solaris: (Solaris 10 only???) +/proc//object/a.out (filename only) +/proc//path/a.out (complete pathname) + +*BSD: +/proc//file +-} + +{-# LANGUAGE ForeignFunctionInterface #-} + +module System.Environment.Executable.BSD + ( getExecutablePath + , getPID + ) + where + +import Data.Bits +import Data.Word +import Data.Int + +import Control.Monad + +import Foreign +import Foreign.C + +import System.Posix +--import System.FilePath + +-------------------------------------------------------------------------------- + +getPID :: IO Int +getPID = liftM fromIntegral $ getProcessID + +getExecutablePath :: IO FilePath +getExecutablePath = do + pid <- getPID + fname <- readSymbolicLink $ "/proc/" ++ show pid ++ "/file" + --let (path,exename) = splitFileName fname + --return path + return fname + +-------------------------------------------------------------------------------- + diff --git a/System/Environment/Executable/Linux.hs b/System/Environment/Executable/Linux.hs new file mode 100644 --- /dev/null +++ b/System/Environment/Executable/Linux.hs @@ -0,0 +1,51 @@ + + +{- +symbolic links to the executable: + +Linux: +/proc//exe + +Solaris: (Solaris 10 only???) +/proc//object/a.out (filename only) +/proc//path/a.out (complete pathname) + +*BSD: +/proc//file +-} + +{-# LANGUAGE ForeignFunctionInterface #-} + +module System.Environment.Executable.Linux + ( getExecutablePath + , getPID + ) + where + +import Data.Bits +import Data.Word +import Data.Int + +import Control.Monad + +import Foreign +import Foreign.C + +import System.Posix +--import System.FilePath + +-------------------------------------------------------------------------------- + +getPID :: IO Int +getPID = liftM fromIntegral $ getProcessID + +getExecutablePath :: IO FilePath +getExecutablePath = do + pid <- getPID + fname <- readSymbolicLink $ "/proc/" ++ show pid ++ "/exe" + --let (path,exename) = splitFileName fname + --return path + return fname + +-------------------------------------------------------------------------------- + diff --git a/System/Environment/Executable/MacOSX.hs b/System/Environment/Executable/MacOSX.hs new file mode 100644 --- /dev/null +++ b/System/Environment/Executable/MacOSX.hs @@ -0,0 +1,152 @@ + +{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls #-} + +module System.Environment.Executable.MacOSX + ( getExecutablePath + , getApplicationBundlePath + ) + where + +import Data.Bits +import Data.Word +import Data.Int + +import Control.Monad + +import Foreign +import Foreign.C + +--import System.FilePath + +-------------------------------------------------------------------------------- + +type UInt8 = Word8 +type UInt16 = Word16 +type UInt32 = Word32 +type UInt64 = Word64 + +type SInt8 = Int8 +type SInt16 = Int16 +type SInt32 = Int32 +type SInt64 = Int64 + +type OSErr = SInt16 +type OSStatus = SInt32 + +type Boolean = Bool +type Float32 = Float +type Float64 = Double + +type UniChar = Char +type CFIndex = SInt32 +type ItemCount = UInt32 +type ByteCount = UInt32 + +data CFData +data CFString +data CFAllocator + +type CFDataRef = Ptr CFData +type CFStringRef = Ptr CFString +type CFAllocatorRef = Ptr CFAllocator + +-------------------------------------------------------------------------------- + +kCFAllocatorDefault :: CFAllocatorRef +kCFAllocatorDefault = nullPtr + +osStatusString :: OSStatus -> String +osStatusString osstatus = "OSStatus = " ++ show osstatus + +osStatusError :: OSStatus -> IO a +osStatusError osstatus = fail $ osStatusString osstatus + +foreign import ccall unsafe "CFBase.h CFRelease" + c_CFRelease :: Ptr a -> IO () + +foreign import ccall unsafe "CFString.h CFStringGetLength" + c_CFStringGetLength :: CFStringRef -> IO CFIndex + +foreign import ccall unsafe "CFString.h CFStringGetCharactersPtr" + c_CFStringGetCharactersPtr :: CFStringRef -> IO (Ptr UniChar) + +foreign import ccall unsafe "CFString.h CFStringGetCharacterAtIndex" + c_CFStringGetCharacterAtIndex :: CFStringRef -> CFIndex -> IO UniChar + +foreign import ccall unsafe "CFString.h CFStringCreateWithCharacters" + c_CFStringCreateWithCharacters :: CFAllocatorRef -> Ptr UniChar -> CFIndex -> IO CFStringRef + +-- | Manually releasing a CFString. +releaseCFString :: CFStringRef -> IO () +releaseCFString = c_CFRelease + +-- | Peeks a CFString. +peekCFString :: CFStringRef -> IO String +peekCFString cfstring = do + n <- c_CFStringGetLength cfstring + p <- c_CFStringGetCharactersPtr cfstring + if p /= nullPtr + then forM [0..n-1] $ \i -> peekElemOff p (fromIntegral i) + else forM [0..n-1] $ \i -> c_CFStringGetCharacterAtIndex cfstring i + +-- | Creates a new CFString. You have to release it manually. +newCFString :: String -> IO CFStringRef +newCFString string = + let n = length string in allocaArray n $ \p -> + c_CFStringCreateWithCharacters kCFAllocatorDefault p (fromIntegral n) + +-- | Safe passing of a CFString to the OS (releases it afterwards). +withCFString :: String -> (CFStringRef -> IO a) -> IO a +withCFString string action = do + cfstring <- newCFString string + x <- action cfstring + releaseCFString cfstring + return x + +-------------------------------------------------------------------------------- + +data CFBundle +type CFBundleRef = Ptr CFBundle + +data CFURL +type CFURLRef = Ptr CFURL + +type OSXEnum = CInt -- ????????????? +type CFURLPathStyle = OSXEnum + +foreign import ccall unsafe "CFBundle.h CFBundleGetMainBundle" + c_CFBundleGetMainBundle :: IO CFBundleRef + +foreign import ccall unsafe "CFBundle.h CFBundleCopyBundleURL" + c_CFBundleCopyBundleURL :: CFBundleRef -> IO CFURLRef + +foreign import ccall unsafe "CFBundle.h CFBundleCopyExecutableURL" + c_CFBundleCopyExecutableURL :: CFBundleRef -> IO CFURLRef + +foreign import ccall unsafe "CFURL.h CFURLCopyFileSystemPath" + c_CFURLCopyFileSystemPath :: CFURLRef -> CFURLPathStyle -> IO CFStringRef + +kCFURLPOSIXPathStyle = 0 :: CFURLPathStyle +kCFURLHFSPathStyle = 1 :: CFURLPathStyle +kCFURLWindowsPathStyle = 2 :: CFURLPathStyle + +-- | Mac OS X only. +getApplicationBundlePath :: IO FilePath +getApplicationBundlePath = do + bundle <- c_CFBundleGetMainBundle + url <- c_CFBundleCopyBundleURL bundle + cfpath <- c_CFURLCopyFileSystemPath url kCFURLPOSIXPathStyle + peekCFString cfpath + +getExecutablePath :: IO FilePath +getExecutablePath = do + bundle <- c_CFBundleGetMainBundle + url <- c_CFBundleCopyExecutableURL bundle + cfpath <- c_CFURLCopyFileSystemPath url kCFURLPOSIXPathStyle + fname <- peekCFString cfpath +-- let (path,exename) = splitFileName fname +-- return path + return fname + + +-------------------------------------------------------------------------------- diff --git a/System/Environment/Executable/Solaris.hs b/System/Environment/Executable/Solaris.hs new file mode 100644 --- /dev/null +++ b/System/Environment/Executable/Solaris.hs @@ -0,0 +1,51 @@ + + +{- +symbolic links to the executable: + +Linux: +/proc//exe + +Solaris: (Solaris 10 only???) +/proc//object/a.out (filename only) +/proc//path/a.out (complete pathname) + +*BSD: +/proc//file +-} + +{-# LANGUAGE ForeignFunctionInterface #-} + +module System.Environment.Executable.Solaris + ( getExecutablePath + , getPID + ) + where + +import Data.Bits +import Data.Word +import Data.Int + +import Control.Monad + +import Foreign +import Foreign.C + +import System.Posix +--import System.FilePath + +-------------------------------------------------------------------------------- + +getPID :: IO Int +getPID = liftM fromIntegral $ getProcessID + +getExecutablePath :: IO FilePath +getExecutablePath = do + pid <- getPID + fname <- readSymbolicLink $ "/proc/" ++ show pid ++ "/path/a.out" + --let (path,exename) = splitFileName fname + --return path + return fname + +-------------------------------------------------------------------------------- + diff --git a/System/Environment/Executable/Win32.hs b/System/Environment/Executable/Win32.hs new file mode 100644 --- /dev/null +++ b/System/Environment/Executable/Win32.hs @@ -0,0 +1,55 @@ + +{-# LANGUAGE ForeignFunctionInterface #-} + +module System.Environment.Executable.Win32 + ( getExecutablePath + , getModulePath + ) + where + +import Data.Bits +import Data.Word +import Data.Int + +import Control.Monad + +import Foreign +import Foreign.C +import Foreign.Marshal + +--import System.Win32 +--import System.Win32.DLL + +-------------------------------------------------------------------------------- + +foreign import stdcall unsafe "Windows.h GetModuleFileNameW" c_GetModuleFileNameW + :: HMODULE -> Ptr CWchar -> Word32 -> IO Word32 + +type HMODULE = Ptr () + +getModulePath :: HMODULE -> IO FilePath +getModulePath = getModulePath' 512 + +getModulePath' :: Word32 -> HMODULE -> IO FilePath +getModulePath' size hmodule = do + mpath <- allocaArray0 (fromIntegral size) $ \p -> do + k <- c_GetModuleFileNameW hmodule p size + case k of + 0 -> error "getModulePath: unknown error" + _ -> if k == size + then return Nothing + else liftM Just $ peekCWString p + case mpath of + Just path -> return path + Nothing -> getModulePath' (2*size) hmodule + +{- +-- | Returns the full path + name of the module. +getModulePath :: HMODULE -> IO FilePath +getModulePath hmodule = getModuleFileName hmodule +-} + +getExecutablePath :: IO FilePath +getExecutablePath = getModulePath nullPtr + +-------------------------------------------------------------------------------- diff --git a/executable-path.cabal b/executable-path.cabal new file mode 100644 --- /dev/null +++ b/executable-path.cabal @@ -0,0 +1,56 @@ +Name: executable-path +Version: 0.0 +Synopsis: Finding out the full path of the executable. + +Description: The documentation of "System.Environment.getProgName" says that + + \"However, this is hard-to-impossible to implement on some non-Unix OSes, + so instead, for maximum portability, we just return the leafname + of the program as invoked.\" + + This library tries to provide the missing path. + +License: PublicDomain +License-file: LICENSE +Author: Balazs Komuves +Maintainer: bkomuves (plus) hackage (at) gmail (dot) com +Homepage: http://code.haskell.org/~bkomuves/ +Stability: Experimental +Category: System +Tested-With: GHC == 6.10.1 +Cabal-Version: >= 1.2 +Build-Type: Simple + +Flag splitBase + Description: Choose the new smaller, split-up base package. + +Library + if flag(splitBase) + Build-Depends: base >=3, filepath + else + Build-Depends: base < 3 + + Exposed-Modules: System.Environment.Executable + Extensions: ForeignFunctionInterface, CPP, EmptyDataDecls + Hs-Source-Dirs: . + + if os(darwin) + Frameworks: CoreFoundation + Other-Modules: System.Environment.Executable.MacOSX + + if os(windows) + Extra-Libraries: kernel32 + Other-Modules: System.Environment.Executable.Win32 + + if os(linux) + Build-Depends: unix + Other-Modules: System.Environment.Executable.Linux + + if os(freebsd) || os(openbsd) || os(netbsd) + Build-Depends: unix + Other-Modules: System.Environment.Executable.BSD + + if os(solaris) + Build-Depends: unix + Other-Modules: System.Environment.Executable.Solaris +