1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
|
-- | This code uses @sysctl@ and @KERN_PROC_PATHNAME@,
-- if we are on FreeBSD 6.0 or newer, and falls back to procfs
-- on older FreeBSD-s.
{-# LANGUAGE CPP, ForeignFunctionInterface #-}
module System.Environment.Executable.FreeBSD
( getExecutablePath
, getPID
)
where
import Data.Bits
import Data.Word
import Data.Int
import Data.Char
import Data.List
import Control.Monad
import Foreign
import Foreign.C
import System.Posix
import System.Directory
--------------------------------------------------------------------------------
#define CTL_KERN 1
#define KERN_PROC 14
#define KERN_PROC_PATHNAME 12
-- KERN_PROC_PATHNAME exists from FreeBSD 6.0
#define ENOMEM 12
#define KERN_OSTYPE 1
#define KERN_OSRELEASE 2
#define KERN_OSREV 3
-- KERN_OSREV gives back a totally random-looking
-- number with a totally undocumented meaning, yeah, fuck that.
#define KERN_VERSION 4
--------------------------------------------------------------------------------
-- the only data point is the string "6.4-RELEASE"
-- yay for undocumented queries!
-- not let's try to parse that
parseOSRelease :: String -> Maybe (Int,Int)
parseOSRelease text =
if major /= "" && temp1 /= "" && minor /= "" && dot == '.'
then Just (read major, read minor)
else Nothing
where
(major,temp1) = span isDigit text
(dot:temp2) = temp1
(minor,rest) = span isDigit temp2
getExecutablePath :: IO FilePath
getExecutablePath = do
{-
osrev <- getKernInt KERN_OSREV
ostype <- getKernString KERN_OSTYPE 256
kver <- getKernString KERN_VERSION 256
print osrev
print ostype
print kver
-}
osrel <- getKernString KERN_OSRELEASE 256
-- print osrel
-- print $ parseOSRelease osrel
case parseOSRelease osrel of
Just (maj,_) -> if maj >= 6
then getExecutablePathSysCtl 256
else getExecutablePathProcFS
Nothing -> getExecutablePathProcFS
--------------------------------------------------------------------------------
-- int sysctl(int *name, u_int namelen, void *oldp, size_t *oldlenp, void *newp, size_t newlen);
foreign import ccall "sys/sysctl.h sysctl"
sysctl :: Ptr CInt -> CUInt -> Ptr a -> Ptr CSize -> Ptr a -> CSize -> IO CInt
-- brrrrrrr...
foreign import ccall "errno.h &errno" errno :: Ptr CInt
getKernString :: CInt -> Int -> IO String
getKernString what len = do
allocaArray 2 $ \mib -> do
pokeArray mib [ CTL_KERN, what ]
alloca $ \buflen -> do
poke buflen (fromIntegral len :: CSize)
allocaBytes len $ \buf -> do
sysctl mib 2 buf buflen nullPtr 0
peekCString buf
getKernInt :: CInt -> IO CInt
getKernInt what = do
allocaArray 2 $ \mib -> do
pokeArray mib [ CTL_KERN, what ]
alloca $ \posrev -> do
alloca $ \buflen -> do
poke buflen (fromIntegral (sizeOf (undefined :: CInt)) :: CSize)
sysctl mib 2 posrev buflen nullPtr 0
peek posrev
getExecutablePathSysCtl :: Int -> IO FilePath
getExecutablePathSysCtl size = do
allocaArray 4 $ \mib -> do
pokeArray mib [ CTL_KERN, KERN_PROC, KERN_PROC_PATHNAME, -1 ] -- @-1@ is current process (could be a PID)
allocaBytes size $ \buf -> do
alloca $ \buflen -> do
poke buflen (fromIntegral size :: CSize)
err <- sysctl mib 4 buf buflen nullPtr 0
case err of
0 -> peekCString buf
-1 -> do
errn <- peek errno
case errn of
ENOMEM -> getExecutablePathSysCtl (size*2)
_ -> error "getExecutablePath: unknown system error"
{-
int mib[4];
mib[0] = CTL_KERN;
mib[1] = KERN_PROC;
mib[2] = KERN_PROC_PATHNAME;
mib[3] = -1;
char buf[1024];
size_t cb = sizeof(buf);
sysctl(mib, 4, buf, &cb, NULL, 0);
-}
--------------------------------------------------------------------------------
-- procfs fallback for FreeBSD < 6.0
getPID :: IO Int
getPID = liftM fromIntegral $ getProcessID
{-
getExecutablePathProcFS :: IO FilePath
getExecutablePathProcFS = do
pid <- getPID
let procPid = "/proc/" ++ show pid ++ "/file"
fname <- readSymbolicLink procPid
return fname
-}
getExecutablePathProcFS :: IO FilePath
getExecutablePathProcFS = do
try1 <- getExecutablePathProcFS' "file"
case try1 of
Just xx -> return xx
Nothing -> do
try2 <- getExecutablePathUnderscoreFallback
case try2 of
Just yy -> return yy
Nothing -> error "getExecutablePath/FreeBSD: unable to obtain the path"
-- eg. @getExecutablePathProcFS "file"@
getExecutablePathProcFS' :: FilePath -> IO (Maybe FilePath)
getExecutablePathProcFS' symlink = do
pid <- getPID
let procPid = "/proc/" ++ show pid ++ "/" ++ symlink
fileExist procPid >>= \b -> if b
then getSymbolicLinkStatus procPid >>= \s -> if isSymbolicLink s
then liftM Just $ readSymbolicLink procPid
else return Nothing
else return Nothing
--------------------------------------------------------------------------------
-- even more fallback, if for some reason procfs doesn't work
-- this is an unreliable fallback trying to
-- get the environment variable named "_".
getExecutablePathUnderscoreFallback :: IO (Maybe FilePath)
getExecutablePathUnderscoreFallback = do
mp <- getEnv "_"
case mp of
Nothing -> return mp
Just p -> do
q <- canonicalizePath p
return (Just q)
--------------------------------------------------------------------------------
|
