Coverage report: /home/ellis/comp/core/lib/obj/uri/path.lisp

Kind	Covered	All	%
expression	0	510	0.0
branch	0	120	0.0

Key

Not instrumented

Conditionalized out

Executed

Not executed

Both branches taken

One branch taken

Neither branch taken

1

;;; obj/uri/path.lisp --- URI Path merging functions

2

3

;;

4

5

;;; Code:

6

(in-package :obj/uri)

7

;; merging and unmerging

8

(defmethod merge-uris ((uri string) (base string) &optional place)

9

(merge-uris (parse-uri uri) (parse-uri base) place))

10

11

(defmethod merge-uris ((uri uri) (base string) &optional place)

12

(merge-uris uri (parse-uri base) place))

13

14

(defmethod merge-uris ((uri string) (base uri) &optional place)

15

(merge-uris (parse-uri uri) base place))

16

17

(defmethod merge-uris ((uri uri) (base uri) &optional place)

18

;; When PLACE is nil, this function returns a new URI.

19

;; When PLACE is non-nil, it is return.

20

(tagbody

21

(when (and (null (uri-path uri))

22

(null (uri-scheme uri))

23

(null (uri-host uri))

24

(null (uri-userinfo uri))

25

(null (uri-port uri))

26

(null (uri-query uri)))

27

(return-from merge-uris

28

(let ((new (copy-uri base :place place)))

29

(when (uri-query uri)

30

(setf (uri-query new) (uri-query uri)))

31

(when (uri-fragment uri)

32

(setf (uri-fragment new) (uri-fragment uri)))

33

new)))

34

35

(setq uri (copy-uri uri :place place))

36

37

(when (uri-scheme uri) (go :done))

38

39

(setf (uri-scheme uri) (uri-scheme base))

40

41

;; if URI has a host, we're done

42

(when (uri-host uri) (go :done))

43

44

(set-host uri

45

(%uri-host base)

46

(%uri-ipv6 base)

47

(%uri-zone-id base))

48

(setf (uri-userinfo uri) (uri-userinfo base))

49

(setf (uri-port uri) (uri-port base))

50

51

(let ((p (uri-parsed-path uri)))

52

(when (null p)

53

(setf (uri-path uri) (uri-path base))

54

(go :done))

55

56

(when (and p (eq :absolute (car p)))

57

(if* (equal '(:absolute "") p)

58

then ;; Canonicalize the way parsing does:

59

(setf (uri-path uri) nil)

60

elseif (eq :absolute (first p))

61

then ;; this also sets uri-path

62

(multiple-value-bind (new changed)

63

(canonicalize-path-list p)

64

(when changed

65

(setf (uri-parsed-path uri) new))))

66

(go :done)))

67

68

(let* ((base-path

69

(or (uri-parsed-path base)

70

;; needed because we canonicalize away a path of just `/':

71

'(:absolute "")))

72

(path (uri-parsed-path uri))

73

new-path-list)

74

(when (not (eq :absolute (car base-path)))

75

(error "Cannot merge ~a and ~a, since the latter is not absolute."

76

uri base))

77

78

(setq new-path-list

79

(append (butlast base-path)

80

(if* path then (cdr path) else '(""))))

81

82

(let ((last (last new-path-list)))

83

(if* (atom (car last))

84

then (when (string= "." (car last))

85

(setf (car last) ""))

86

else (when (string= "." (caar last))

87

(setf (caar last) ""))))

88

(setq new-path-list

89

(delete "." new-path-list :test #'(lambda (a b)

90

(if* (atom b)

91

then (string= a b)

92

else nil))))

93

94

(let ((npl (cdr new-path-list))

95

index tmp fix-tail)

96

(setq fix-tail

97

(string= ".." (let ((l (car (last npl))))

98

(if* (atom l)

99

then l

100

else (car l)))))

101

(loop

102

(setq index

103

(position ".." npl

104

:test #'(lambda (a b)

105

(string= a

106

(if* (atom b)

107

then b

108

else (car b))))))

109

(when (null index) (return))

110

111

(if* (= 0 index)

112

then ;; rfe11852: RFC 3986, in section 5.4.2 (Abnormal

113

;; Examples) says parsers; must be careful in handling

114

;; cases where there are more ".." segments in a

115

;; relative-path reference than there are in the base

116

;; URI's path. The examples, between the two RFC's were

117

;; changed to show the additional, leading ..'s to be

118

;; removed. So, we'll do that now.

119

(setq npl (cdr npl))

120

elseif (= 1 index)

121

then (setq npl (cddr npl))

122

else (setq tmp npl)

123

(dotimes (x (- index 2)) (setq tmp (cdr tmp)))

124

(setf (cdr tmp) (cdddr tmp))))

125

(setf (cdr new-path-list) npl)

126

(when fix-tail (setq new-path-list (nconc new-path-list '("")))))

127

128

(when (eq :absolute (first new-path-list))

129

(multiple-value-bind (new changed)

130

(canonicalize-path-list new-path-list)

131

(when changed (setq new-path-list new))))

132

133

;; Also sets uri-path:

134

(setf (uri-parsed-path uri) new-path-list))

135

136

:done

137

(return-from merge-uris uri)))

138

139

(defun canonicalize-path-list (path-list &aux changed)

140

;; Return two values: new version of PATH-LIST and an indicator if it was

141

;; changed. We are only called when (car path-list) is :absolute.

142

(loop while (or (equal "." (second path-list))

143

(equal ".." (second path-list)))

144

do (setf (cdr path-list) (cddr path-list))

145

(setq changed t))

146

(values path-list changed))

147

148

(defmethod merge-uris ((urn urn) (base urn) &optional place)

149

(if* place

150

then (setf (urn-nid place) (urn-nid urn))

151

(setf (urn-nss place) (urn-nss urn))

152

place

153

else urn))

154

155

(defmethod merge-uris ((urn urn) (base uri) &optional place)

156

(if* place

157

then (setf (urn-nid place) (urn-nid urn))

158

(setf (urn-nss place) (urn-nss urn))

159

place

160

else urn))

161

162

(defmethod merge-uris ((uri uri) (base urn) &optional place)

163

(copy-uri uri :place place))

164

165

(defmethod enough-uri ((uri string) (base string) &optional place)

166

(enough-uri (parse-uri uri) (parse-uri base) place))

167

168

(defmethod enough-uri ((uri uri) (base string) &optional place)

169

(enough-uri uri (parse-uri base) place))

170

171

(defmethod enough-uri ((uri string) (base uri) &optional place)

172

(enough-uri (parse-uri uri) base place))

173

174

(defmethod enough-uri ((uri uri) (base uri) &optional place)

175

;; Like ENOUGH-PATHNAME, but for URIs.

176

(let ((new-scheme nil)

177

(new-host nil)

178

(new-ipv6 nil)

179

(new-zone-id nil)

180

(new-userinfo nil)

181

(new-port nil)

182

(new-parsed-path nil))

183

184

;; If the scheme and authority are not the same, then return URI.

185

(when (or (and (uri-scheme uri)

186

(not (equalp (uri-scheme uri) (uri-scheme base))))

187

;; We don't use uri-authority, because it conses a lot.

188

(and (uri-host uri)

189

(not (equalp (uri-host uri) (uri-host base))))

190

(not (equalp (uri-userinfo uri) (uri-userinfo base)))

191

(not (equalp (uri-port uri) (uri-port base))))

192

(return-from enough-uri uri))

193

194

;; For this group, if the slot is nil in URI, then the return value is

195

;; copied from from BASE:

196

(when (null (uri-scheme uri)) (setq new-scheme (uri-scheme base)))

197

(when (null (uri-host uri))

198

;; These are copied as a unit:

199

(setq new-host (%uri-host base))

200

(setq new-ipv6 (%uri-ipv6 base))

201

(setq new-zone-id (%uri-zone-id base)))

202

(when (null (uri-userinfo uri)) (setq new-userinfo (uri-userinfo base)))

203

(when (null (uri-port uri)) (setq new-port (uri-port base)))

204

205

;; Now, for the hard one, path.

206

;; We essentially do here what enough-namestring does.

207

(do* ((base-path (uri-parsed-path base))

208

(path (uri-parsed-path uri))

209

(bp base-path (cdr bp))

210

(p path (cdr p)))

211

((or (null bp) (null p))

212

;; If p is nil, that means we have something like

213

;; (enough-uri "/foo/bar" "/foo/bar/baz.htm"), so

214

;; new-parsed-path will be nil.

215

(when (null bp)

216

(setq new-parsed-path (copy-list p))

217

(when (not (symbolp (car new-parsed-path)))

218

(push :relative new-parsed-path))))

219

(if* (equal (car bp) (car p))

220

thenret ;; skip it

221

else (setq new-parsed-path (copy-list p))

222

(when (not (symbolp (car new-parsed-path)))

223

(push :relative new-parsed-path))

224

(return)))

225

226

(let ((new-path

227

(or (when new-parsed-path

228

(render-parsed-path new-parsed-path

229

;; don't know, so have to assume:

230

t))

231

;; can't have a completely empty uri!

232

"/")))

233

(copy-uri nil :class (class-of uri) :place place

234

;;; these come from base if the original slot was nil

235

:scheme new-scheme

236

:host new-host

237

:ipv6 new-ipv6

238

:zone-id new-zone-id

239

:userinfo new-userinfo

240

:port new-port

241

:path new-path

242

:parsed-path new-parsed-path

243

;;; never from base... why? is this documented?

244

:query (uri-query uri)

245

:fragment (uri-fragment uri)

246

:plist (copy-list (uri-plist uri))))))

247

248

(defmethod enough-uri ((urn urn) (base urn) &optional place)

249

(if* place

250

then (setf (urn-nid place) (urn-nid urn))

251

(setf (urn-nss place) (urn-nss urn))

252

place

253

else urn))

254

255

(defmethod enough-uri ((urn urn) (base uri) &optional place)

256

(declare (ignore place))

257

(error "enough-uri of a URN (~a) and URI (~a)." urn base))

258

259

(defmethod enough-uri ((uri uri) (base urn) &optional place)

260

(declare (ignore place))

261

(error "enough-uri of a URI (~a) and URN (~a)." uri base))

262

263

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

264

265

(defun uri-to-pathname (uri)

266

;; On Windows, turn file:///d:/foo/bar.cl into #p"d:/foo/bar.cl"

267

;; On UNIX, turn file:///foo/bar.cl into #p"/foo/bar.cl"

268

(when (not (eq :file (uri-scheme uri)))

269

(error "Only file: URIs can be converted to pathnames: ~s." uri))

270

(when (null (uri-path uri)) (error "URI has no path: ~s." uri))

271

(pathname

272

(percent-decode-string

273

(uri-path uri)

274

nil)))

275

276

(defun pathname-to-uri (pathname)

277

(when (not (uiop:absolute-pathname-p pathname t))

278

(error "A relative pathname cannot be converted to a URI: ~s." pathname))

279

(parse-uri

280

(let ((s (percent-encode-string

281

#+mswindows (substitute #\/ #\\ (namestring pathname))

282

#-mswindows (namestring pathname)

283

*pchar/-bitvector*)))

284

#-mswindows (format nil "file://~a" s)

285

#+mswindows (if* (pathname-device pathname)

286

then (format nil "file:///~a" s)

287

else (format nil "file://~a" s)))))