File: xmlrep-helpers.lisp

package info (click to toggle)
cl-xmls 3.0.2-1
  • links: PTS, VCS
  • area: main
  • in suites: bullseye, buster, sid
  • size: 720 kB
  • sloc: xml: 7,639; lisp: 1,084; perl: 101; makefile: 39
file content (131 lines) | stat: -rw-r--r-- 4,879 bytes parent folder | download
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
;;;---------------------------------------------------------------------------
;;; File Description:
;;;
;;;    Contains utility functions that are helpful in manipulating the
;;;    list representation that XMLS uses as the source or destination
;;;    of translation to or from XML.
;;;
;;; History/Bugs/Notes:
;;;
;;;   [2004/09/15:Robert P. Goldman] Created.
;;;
;;;---------------------------------------------------------------------------
(in-package :xmls)

(defun make-xmlrep (tag &key attribs children)
  (make-node :name tag :attrs attribs :children children))

(defun xmlrep-add-child! (xmlrep child)
  (setf (node-children xmlrep)
        (append (node-children xmlrep)
                (list child))))

(defun xmlrep-tag (treenode)
  (node-name treenode))

(defun xmlrep-tagmatch (tag treenode)
  (unless (stringp treenode)            ; child nodes to XMLREPs could be strings or nodes
    (string-equal tag (xmlrep-tag treenode))))

(defun xmlrep-attribs (treenode)
  (node-attrs treenode))

(defun (setf xmlrep-attribs) (attribs treenode)
  (setf (node-attrs treenode) attribs))

(defun xmlrep-children (treenode)
  (node-children treenode))

(defun (setf xmlrep-children) (children treenode)
  (setf (node-children treenode) children))

(defun xmlrep-string-child (treenode &optional (if-unfound :error))
  (let ((children (xmlrep-children treenode)))
    (if (and (eq (length children) 1) (typep (first children) 'string))
        (first children)
        (if (eq if-unfound :error)
            (error "Node does not have a single string child: ~a" treenode)
            if-unfound)
        )))

(defun xmlrep-integer-child (treenode)
  (parse-integer (xmlrep-string-child treenode)))

(defun xmlrep-find-child-tags (tag treenode)
  "Find all the children of TREENODE with TAG."
  (remove-if-not #'(lambda (child) (xmlrep-tagmatch tag child))
                 (xmlrep-children treenode)))

(defun xmlrep-find-child-tag (tag treenode
                                  &optional (if-unfound :error))
  "Find a single child of TREENODE with TAG.  Returns an error
if there is more or less than one such child."
  (let ((matches (xmlrep-find-child-tags tag treenode)))
    (case (length matches)
      (0 (if (eq if-unfound :error)
             (error "Couldn't find child tag ~A in ~A"
                tag treenode)
             if-unfound))
      (1 (first matches))
      (otherwise (error "Child tag ~A multiply defined in ~A"
                        tag treenode)))))

(defun xmlrep-attrib-value (attrib treenode
                            &optional (if-undefined :error))
  "Find the value of ATTRIB, a string, in TREENODE.
if there is no ATTRIB, will return the value of IF-UNDEFINED,
which defaults to :ERROR."
  (let ((found-attrib (find-attrib attrib treenode)))
    (cond (found-attrib
           (second found-attrib))
          ((eq if-undefined :error)
           (error "XML attribute ~S undefined in ~S"
                  attrib treenode))
          (t
           if-undefined))))

(defun find-attrib (attrib treenode)
  "Returns the attrib CELL (not the attrib value) from 
TREENODE, if found.  This cell will be a list of length 2,
the attrib name (a string) and its value."
  (find attrib (xmlrep-attribs treenode)
        :test #'string=
        :key #'car))
  
(defun (setf xmlrep-attrib-value) (value attrib treenode)
  ;; ideally, we would check this...
  (let ((old-val (xmlrep-attrib-value attrib treenode nil)))
    (if old-val
        (cond ((null value)
               ;; just delete this attribute...
               (setf (xmlrep-attribs treenode)
                     (remove attrib (xmlrep-attribs treenode)
                             :test #'string=
                             :key #'first))
               nil)
              (t (let ((cell (find-attrib attrib treenode)))
                   (setf (second cell) value)
                   value)))
        ;; no old value
        (cond ((null value)
               nil)                         ; no old value to delete
              (t
               (setf (xmlrep-attribs treenode)
                     (append (xmlrep-attribs treenode)
                             (list (list attrib value))))
               value)))))

(defun xmlrep-boolean-attrib-value (attrib treenode
                                    &optional (if-undefined :error))
  "Find the value of ATTRIB, a string, in TREENODE.
The value should be either \"true\" or \"false\".  The
function will return T or NIL, accordingly.  If there is no ATTRIB,
will return the value of IF-UNDEFINED, which defaults to :ERROR."
  (let ((val (xmlrep-attrib-value attrib treenode
                                  if-undefined)))
    (cond ((string-equal val "true")
           t)
          ((string-equal val "false") nil)
          (t (error "Not a boolean value, ~A for attribute ~A."
                    val attrib)))))