Coverage report: /home/ellis/comp/core/lib/io/disk/util.lisp

Kind	Covered	All	%
expression	0	304	0.0
branch	0	10	0.0

Key

Not instrumented

Conditionalized out

Executed

Not executed

Both branches taken

One branch taken

Neither branch taken

1

;;; util.lisp --- Disk Utilities

2

3

;;

4

5

;;; Code:

6

(in-package :io/disk)

7

8

;;; Unix Mntent

9

(define-alien-type mntent

10

(struct mntent

11

(mnt-fsname c-string)

12

(mnt-dir c-string)

13

(mnt-type c-string)

14

(mnt-opts c-string)

15

(mnt-freq int)

16

(mnt-passno int)))

17

18

(define-alien-routine setmntent (* mntent) (filename c-string) (type c-string))

19

(define-alien-routine getmntent (* mntent) (stream (* t)))

20

(define-alien-routine endmntent int (stream (* t)))

21

22

(define-constant +option-separator+ "," :test #'string=)

23

24

(define-constant +suboption-separator+ "=" :test #'string=)

25

26

(define-condition open-file-failed (error)

27

((file-path

28

:initarg :file-path

29

:reader file-path))

30

(:report

31

(lambda (condition stream)

32

(format stream

33

"Can not get mount filesystem information: unable to open file ~a"

34

(file-path condition))))

35

(:documentation "Length error"))

36

37

(defun mntent-all-infos (&optional (mount-info-file "/etc/mtab"))

38

(let ((root-info (setmntent mount-info-file "ro"))

39

(infos))

40

(if (not (null-alien root-info))

41

(labels ((get-info ()

42

(let ((info (getmntent root-info)))

43

(if (not (null-alien info))

44

(progn

45

(push info infos)

46

(get-info))

47

infos))))

48

(prog1

49

(get-info)

50

(endmntent root-info)))

51

(error 'open-file-failed :file-path mount-info-file))))

52

53

(defun mntent-info (mtab plist-key looking-for-value)

54

(let ((all-infos (mntent-all-infos mtab)))

55

(find-if (lambda (a)

56

(when-let ((value-found (slot a plist-key)))

57

(string= value-found looking-for-value)))

58

all-infos)))

59

60

(declaim (inline all-infos))

61

(defun all-infos (&optional (mount-info-file "/etc/mtab"))

62

(mntent-all-infos mount-info-file))

63

64

(defun mountpoint-get (mount-info-file mountpoint key)

65

(when-let ((infos (mntent-info mount-info-file 'mnt-dir mountpoint)))

66

(slot infos key)))

67

68

(defun mountpoint-directory (mountpoint &optional default (mount-info-file "/etc/mtab"))

69

(or (mountpoint-get mount-info-file mountpoint 'mnt-dir) default))

70

71

(defun mountpoint-device (mountpoint &optional default (mount-info-file "/etc/mtab"))

72

(or (mountpoint-get mount-info-file mountpoint 'mnt-fsname) default))

73

74

(defun mountpoint-fstype (mountpoint &optional (mount-info-file "/etc/mtab"))

75

(mountpoint-get mount-info-file mountpoint 'mnt-type))

76

77

(defun mountpoint-options (mountpoint &optional (mount-info-file "/etc/mtab"))

78

(let* ((raw (mountpoint-get mount-info-file mountpoint 'mnt-opts))

79

(comma-splitted (cl-ppcre:split +option-separator+ raw)))

80

(loop for i in comma-splitted collect

81

(if (cl-ppcre:scan +suboption-separator+ i)

82

(cl-ppcre:split +suboption-separator+ i)

83

i))))

84

85

(defun all-mountpoints (&optional (mount-info-file "/etc/mtab"))

86

(mapcar

87

(lambda (i)

88

(with-alien-slots (mnt-fsname mnt-dir mnt-type mnt-opts) i

89

(list :fsname mnt-fsname :type mnt-type

90

:opts mnt-opts :dir mnt-dir)))

91

(all-infos mount-info-file)))

92

93

;;; Unix Statvfs

94

(define-alien-type fsblkcnt-t unsigned-long)

95

(define-alien-type fsfilcnt-t unsigned-long)

96

97

(define-alien-type statvfs

98

(struct statvfs

99

(bsize unsigned-long)

100

(frsize unsigned-long)

101

(blocks fsblkcnt-t)

102

(bfree fsblkcnt-t)

103

(bavail fsblkcnt-t)

104

(files fsfilcnt-t)

105

(ffree fsfilcnt-t)

106

(favail fsfilcnt-t)

107

(fsig unsigned-long)

108

(flag unsigned-long)

109

(namemax unsigned-long)))

110

111

(define-constant +mntopt-defaults+ "defaults" :test 'equal)

112

(define-constant +mntopt-ro+ "ro" :test 'equal)

113

(define-constant +mntopt-rw+ "rw" :test 'equal)

114

(define-constant +mntopt-suid+ "suid" :test 'equal)

115

(define-constant +mntopt-nosuid+ "nosuid" :test 'equal)

116

(define-constant +mntopt-noauto+ "noauto" :test 'equal)

117

118

;; (constant (st-rdonly "ST_RDONLY"))

119

;; (constant (st-nosuid "ST_NOSUID"))

120

121

(sb-alien:define-alien-routine ("statvfs" %statvfs) sb-alien:int

122

(path sb-alien:c-string)

123

(buf (* statvfs)))

124

125

(defun statvfs (path)

126

(with-alien ((buf (* statvfs) (make-alien statvfs)))

127

(%statvfs path buf)

128

(unwind-protect

129

          (with-alien-slots (bsize frsize blocks bfree bavail files ffree favail fsig flag namemax) buf

130

(values bsize frsize blocks bfree bavail files

131

ffree favail fsig flag namemax))

132

(free-alien buf))))

133

134

;;; Disk Info

135

(defun disk-space (path &optional human-readable-p)

136

"Disk space information including total/free/available space."

137

(multiple-value-bind (bsize frsize blocks bfree bavail files

138

ffree favail fsig flag namemax)

139

(statvfs path)

140

(declare (ignore bsize files ffree favail fsig flag namemax))

141

(if human-readable-p

142

(values (human-readable-size (* frsize blocks))

143

(human-readable-size (* frsize bfree))

144

(human-readable-size (* frsize bavail)))

145

(values (* frsize blocks) (* frsize bfree) (* frsize bavail)))))

146

147

(defun disk-total-space (path &optional human-readable-p)

148

"Disk total space."

149

(multiple-value-bind (bsize frsize blocks bfree bavail files

150

ffree favail fsig flag namemax)

151

(statvfs path)

152

(declare (ignore bsize bfree bavail files ffree favail fsig flag namemax))

153

(if human-readable-p

154

(human-readable-size (* frsize blocks))

155

(* frsize blocks))))

156

157

(defun disk-free-space (path &optional human-readable-p)

158

"Disk free space."

159

(multiple-value-bind (bsize frsize blocks bfree bavail files

160

ffree favail fsig flag namemax)

161

(statvfs path)

162

(declare (ignore bsize blocks bavail files ffree favail fsig flag namemax))

163

(if human-readable-p

164

(human-readable-size (* frsize bfree))

165

(* frsize bfree))))

166

167

(defun disk-available-space (path &optional human-readable-p)

168

"Disk available space."

169

(multiple-value-bind (bsize frsize blocks bfree bavail files

170

ffree favail fsig flag namemax)

171

(statvfs path)

172

(declare (ignore bsize blocks bfree files ffree favail fsig flag namemax))

173

(if human-readable-p

174

(human-readable-size (* frsize bavail))

175

(* frsize bavail))))

176

177

(defun disk-use-percent (path)

178

(/ (disk-available-space path) (disk-total-space path)))

179

180

;;; Commands

181

(defun list-disks (&optional (info t))

182

"List all physical disk use command line tool df. note: size in KB."

183

(let ((disk-info-string (with-output-to-string (stream)

184

(sb-ext:run-program

185

"/bin/sh"

186

#+linux

187

'("-c" "/bin/df" "-P" "|" "grep" "^/dev")

188

#+bsd

189

'("-c" "/bin/df" "-k" "|" "grep" "^/dev")

190

:output stream))))

191

(remove-if

192

#'null

193

(loop for disk-info in (ppcre:split "\\n" disk-info-string)

194

collect

195

#+linux

196

(ppcre:register-groups-bind (filesystem size used available use-percent mounted-on)

197

("^(.+)\\s+(\\d+)\\s+(\\d+)\\s+(\\d+)\\s+(\\d+)%\\s+(.+)$"

198

disk-info)

199

(declare (ignorable filesystem size used available use-percent))

200

(let ((mnt (string-trim " " mounted-on)))

201

(if info

202

(list mnt (string-trim " " filesystem)

203

(parse-integer size)

204

(parse-integer used)

205

(parse-integer available)

206

(parse-integer use-percent))

207

mnt)))

208

;; for Mac OS X

209

#+bsd

210

(ppcre:register-groups-bind (filesystem size used available use-percent

211

                                                       iused ifree iuse-percent mounted-on)

212

                   ("^(.+)\\s+(\\d+)\\s+(\\d+)\\s+(\\d+)\\s+(\\d+)%\\s+(\\d+)\\s+(\\d+)\\s+(\\d+)%\\s+(.+)$"

213

disk-info)

214

(declare (ignore filesystem size used available use-percent

215

iused ifree iuse-percent))

216

(string-trim '(#\Space) mounted-on))))))

217

218

(defun disk-info (disk &optional human-readable-p)

219

(multiple-value-bind (total free available)

220

(disk-space disk)

221

(if human-readable-p

222

(list :disk disk

223

:total (human-readable-size total)

224

:free (human-readable-size free)

225

:available (human-readable-size available)

226

:used (truncate (/ (* (- total available) 100) total)))

227

(list :disk disk

228

:total total

229

:free free

230

:available available

231

:used (truncate (/ (* (- total available) 100) total))))))

232

233

(defun list-disk-info (&optional human-readable-p)

234

"List disk information. example result:

235

\(\(:DISK \"/\" :TOTAL 19993329664 :FREE 6154420224 :AVAILABLE 6154420224

236

:USE-PERCENT 69)

237

\(:DISK \"/mnt\" :TOTAL 21136445440 :FREE 2048335872 :AVAILABLE 974667776

238

:USE-PERCENT 95))

239

240

\(\(:DISK \"/\" :TOTAL \"18.62 GB\" :FREE \"5.73 GB\" :AVAILABLE \"5.73 GB\" :USE-PERCENT

241

69)

242

\(:DISK \"/mnt\" :TOTAL \"19.68 GB\" :FREE \"1.91 GB\" :AVAILABLE \"929.52 MB\"

243

:USE-PERCENT 95))"

244

(loop for disk in (list-disks nil)

245

collect (disk-info disk human-readable-p)))