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

Kind	Covered	All	%
expression	14	167	8.4
branch	0	38	0.0

Key

Not instrumented

Conditionalized out

Executed

Not executed

Both branches taken

One branch taken

Neither branch taken

1

;;; obj/uri/intern.lisp --- Support for URI interning

2

3

;; support for interning URIs

4

5

;;; Code:

6

(in-package :obj/uri)

7

8

(defmethod uri= ((uri1 uri) (uri2 uri))

9

(when (not (eq (uri-scheme uri1) (uri-scheme uri2)))

10

(return-from uri= nil))

11

;; RFC2396 says: a URL with an explicit ":port", where the port is

12

;; the default for the scheme, is the equivalent to one where the

13

;; port is elided. Hmmmm. This means that this function has to be

14

;; scheme dependent. Grrrr.

15

(let ((default-port (case (uri-scheme uri1)

16

(:http 80)

17

(:https 443)

18

(:ftp 21)

19

(:telnet 23))))

20

(and (equalp (uri-host uri1) (uri-host uri2))

21

(equalp (uri-userinfo uri1) (uri-userinfo uri2))

22

(eql (or (uri-port uri1) default-port)

23

(or (uri-port uri2) default-port))

24

(string= (uri-path uri1) (uri-path uri2))

25

(string= (uri-query uri1) (uri-query uri2))

26

(string= (uri-fragment uri1) (uri-fragment uri2)))))

27

28

(defmethod uri= ((urn1 urn) (urn2 urn))

29

(when (not (eq (uri-scheme urn1) (uri-scheme urn2)))

30

(return-from uri= nil))

31

(and (equalp (urn-nid urn1) (urn-nid urn2))

32

(urn-nss-equal (urn-nss urn1) (urn-nss urn2))))

33

34

(defun make-uri-space (&rest keys &key (size 777) &allow-other-keys)

35

(apply #'make-hash-table :size size :hash-function 'uri-hash

36

:test 'uri= keys))

37

38

(defun uri-hash (uri)

39

(if* (uri-hashcode uri)

40

thenret

41

else (setf (uri-hashcode uri) (sxhash (render-uri uri nil)))))

42

43

(defvar *uris* (make-uri-space))

44

45

(defun uri-space () *uris*)

46

47

(defun (setf uri-space) (new-val)

48

(setq *uris* new-val))

49

50

(defun urn-nss-equal (nss1 nss2 &aux len)

51

;; Return t iff the nss values are the same.

52

;; %2c and %2C are equivalent.

53

(when (or (null nss1) (null nss2)

54

(not (= (setq len (length nss1))

55

(length nss2))))

56

(return-from urn-nss-equal nil))

57

(do* ((i 0 (1+ i))

58

(state :char)

59

c1 c2)

60

((= i len) t)

61

(setq c1 (schar nss1 i))

62

(setq c2 (schar nss2 i))

63

(ecase state

64

(:char

65

(if* (and (char= #\% c1) (char= #\% c2))

66

then (setq state :percent+1)

67

elseif (char/= c1 c2)

68

then (return nil)))

69

(:percent+1

70

(when (char-not-equal c1 c2) (return nil))

71

(setq state :percent+2))

72

(:percent+2

73

(when (char-not-equal c1 c2) (return nil))

74

(setq state :char)))))

75

76

(defmethod intern-uri ((xuri uri) &optional (uri-space *uris*))

77

(let ((uri (gethash xuri uri-space)))

78

(if* uri

79

thenret

80

else (nyi!))))

81

82

(defmethod intern-uri ((uri string) &optional (uri-space *uris*))

83

(intern-uri (parse-uri uri) uri-space))

84

85

(defun unintern-uri (uri &optional (uri-space *uris*))

86

(if* (eq t uri)

87

then (clrhash uri-space)

88

elseif (uri-p uri)

89

then (remhash uri uri-space)

90

else (error "bad uri: ~s." uri)))

91

92

(defmacro do-all-uris ((var &optional uri-space result-form)

93

&body body)

94

"do-all-uris (var [[uri-space] result-form])

95

{declaration}* {tag | statement}*

96

Executes the forms once for each uri with var bound to the current uri"

97

(let ((f (gensym))

98

(g-ignore (gensym))

99

(g-uri-space (gensym)))

100

`(let ((,g-uri-space (or ,uri-space *uris*)))

101

(prog nil

102

(flet ((,f (,var &optional ,g-ignore)

103

(declare (ignorable ,var ,g-ignore))

104

(tagbody ,@body)))

105

(maphash #',f ,g-uri-space))

106

(return ,result-form)))))