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

Kind	Covered	All	%
expression	141	328	43.0
branch	8	36	22.2

Key

Not instrumented

Conditionalized out

Executed

Not executed

Both branches taken

One branch taken

Neither branch taken

1

;;; obj/uri/print.lisp --- URI printers

2

3

;;

4

5

;;; Code:

6

(in-package :obj/uri)

7

(defvar *render-include-slash-on-null-path* nil) ;; rfe11850

8

(defvar *uri-schema-print-case* :downcase)

9

(defgeneric render-uri (uri &optional stream))

10

(defmethod render-uri ((uri uri) &optional stream

11

&aux (encode (uri-escaped uri))

12

(*print-pretty* nil)

13

res)

14

(declare (optimize (safety 0)))

15

(when (null (setq res (uri-string uri)))

16

(setf (uri-string uri)

17

(let ((scheme (uri-scheme uri))

18

(host (%uri-host uri))

19

(ipv6 (%uri-ipv6 uri))

20

zone-id ;; don't compute until needed

21

(userinfo (uri-userinfo uri))

22

(port (uri-port uri))

23

(path (uri-path uri))

24

(query (uri-query uri))

25

(fragment (uri-fragment uri)))

26

(setq res

27

(concatenate 'string

28

(when scheme

29

(case *uri-schema-print-case*

30

((:downcase)

31

(string-downcase (symbol-name scheme)))

32

((:upcase)

33

(symbol-name scheme))))

34

(when scheme ":")

35

(when (or host ipv6 (eq :file scheme) (eq :hdfs scheme))

36

"//")

37

(when userinfo

38

(if* encode

39

then (percent-encode-string userinfo *userinfo-bitvector*)

40

else userinfo))

41

(when userinfo "@")

42

(if* ipv6

43

then (if* (setq zone-id (%uri-zone-id uri))

44

then (concatenate 'string "[" ipv6 "%25" zone-id "]")

45

else (concatenate 'string "[" ipv6 "]"))

46

elseif host

47

then (if* encode

48

then (percent-encode-string host *reg-name-bitvector*)

49

else host))

50

(when port (format nil ":~d" port))

51

(if* path

52

then path

53

elseif (and *render-include-slash-on-null-path*

54

#|no path but:|# scheme host)

55

then "/")

56

(when query "?")

57

(when query

58

(if* encode

59

then (percent-encode-string

60

query

61

(if* *strict-parse*

62

then *query-bitvector-strict*

63

else *query-bitvector-non-strict*))

64

else query))

65

(when fragment "#")

66

(when fragment

67

(if* encode

68

then (percent-encode-string

69

fragment

70

(if* *strict-parse*

71

then *fragment-bitvector-strict*

72

else *fragment-bitvector-non-strict*))

73

else fragment))))))

74

75

;; calculate this cached slot

76

(uri-parsed-path uri))

77

78

(if* stream

79

then (princ res stream)

80

else res))

81

82

(defmethod render-uri ((urn urn) &optional stream

83

&aux (*print-pretty* nil))

84

;; This doesn't do encoding because no decoding is done for URNs when

85

;; they are parsed.

86

(when (null (uri-string urn))

87

(setf (uri-string urn)

88

(let ((nid (urn-nid urn))

89

(nss (urn-nss urn))

90

(r (urn-r-component urn))

91

(q (urn-q-component urn))

92

(f (urn-f-component urn)))

93

(concatenate 'string "urn:" nid ":" nss

94

(when r "?+")

95

(when r r)

96

(when q "?=")

97

(when q q)

98

(when f "#")

99

(when f f)))))

100

(if* stream

101

then (write-string (uri-string urn) stream)

102

else (uri-string urn)))

103

104

(defmethod uri-to-string ((uri uri)

105

&aux (encode (uri-escaped uri))

106

(*print-pretty* nil)

107

res)

108

(declare (optimize (safety 0)))

109

(when (null (setq res (uri-string uri)))

110

(setf (uri-string uri)

111

(let ((scheme (uri-scheme uri))

112

(host (%uri-host uri))

113

(ipv6 (%uri-ipv6 uri))

114

zone-id ;; don't compute until needed

115

(userinfo (uri-userinfo uri))

116

(port (uri-port uri))

117

(path (uri-path uri))

118

(query (uri-query uri))

119

(fragment (uri-fragment uri)))

120

(setq res

121

(concatenate 'string

122

(when scheme

123

(case *uri-schema-print-case*

124

((:downcase)

125

(string-downcase (symbol-name scheme)))

126

((:upcase)

127

(symbol-name scheme))))

128

(when scheme ":")

129

(when (or host ipv6 (eq :file scheme) (eq :hdfs scheme))

130

"//")

131

(when userinfo

132

(if* encode

133

then (percent-encode-string userinfo *userinfo-bitvector*)

134

else userinfo))

135

(when userinfo "@")

136

(if* ipv6

137

then (if* (setq zone-id (%uri-zone-id uri))

138

then (concatenate 'string "[" ipv6 "%25" zone-id "]")

139

else (concatenate 'string "[" ipv6 "]"))

140

elseif host

141

then (if* encode

142

then (percent-encode-string host *reg-name-bitvector*)

143

else host))

144

(when port ":")

145

(when port port)

146

(if* path

147

then path

148

elseif (and *render-include-slash-on-null-path*

149

#|no path but:|# scheme host)

150

then "/")

151

(when query "?")

152

query

153

(when fragment "#")

154

(when fragment

155

(if* encode

156

then (percent-encode-string

157

fragment

158

(if* *strict-parse*

159

then *fragment-bitvector-strict*

160

else *fragment-bitvector-non-strict*))

161

else fragment))))))

162

163

;; calculate this cached slot

164

(uri-parsed-path uri))

165

166

res)

167

168

(defmethod iri-to-string ((iri iri))

169

(uri-to-string iri))

170

171

(defmethod uri-to-string ((urn urn))

172

;; We can use render-uri here because no decoding/encoding happens for

173

;; URNs.

174

(render-uri urn))

175

176

(defun render-parsed-path (path-list escape)

177

(do* ((res '())

178

(first (car path-list))

179

(pl (cdr path-list) (cdr pl))

180

(pe (car pl) (car pl)))

181

((null pl)

182

(when res (apply #'concatenate 'string (nreverse res))))

183

(when (or (null first)

184

(prog1 (and (eq :absolute first)

185

;; Only happens on Windows, in the case of a path

186

;; with a drive letter in it. The drive letter

187

;; element is a keyword naming the drive.

188

(not (keywordp pe)))

189

(setq first nil)))

190

(push "/" res))

191

(if* (symbolp pe)

192

then ;; Only happens on Windows. It's a keyword corresponding to

193

;; the drive letter.

194

(push (format nil "~a:" pe) res)

195

elseif (atom pe)

196

then (if* escape

197

then (push (percent-encode-string pe *pchar-bitvector*)

198

res)

199

else (push pe res))

200

else ;; contains params

201

(if* escape

202

then (push (percent-encode-string (car pe) *pchar-bitvector*)

203

res)

204

else (push (car pe) res))

205

(dolist (item (cdr pe))

206

(push ";" res)

207

(if* escape

208

then (push (percent-encode-string item *pchar-bitvector*)

209

res)

210

else (push item res))))))

211

212

(defmethod print-object ((uri uri) stream)

213

(if* *print-escape*

214

then (format stream "#<~a ~a>"

215

(class-name (class-of uri))

216

(render-uri uri))

217

else (render-uri uri stream)))