[cl-soap-cvs] CVS update: cl-soap/src/lxml.lisp

[Sven Van Caekenberghe]

Update of /project/cl-soap/cvsroot/cl-soap/src
In directory common-lisp.net:/tmp/cvs-serv23895/src

Modified Files:
	lxml.lisp 
Log Message:
added example sexpr-get, (setf sexpr-getf), sexpr-select and sexpr-remove

Date: Mon Oct  3 14:29:21 2005
Author: scaekenberghe

Index: cl-soap/src/lxml.lisp
diff -u cl-soap/src/lxml.lisp:1.8 cl-soap/src/lxml.lisp:1.9
--- cl-soap/src/lxml.lisp:1.8	Fri Sep 30 21:56:00 2005
+++ cl-soap/src/lxml.lisp	Mon Oct  3 14:29:21 2005
@@ -1,8 +1,8 @@
 ;;;; -*- mode: lisp -*-
 ;;;;
-;;;; $Id: lxml.lisp,v 1.8 2005/09/30 19:56:00 scaekenberghe Exp $
+;;;; $Id: lxml.lisp,v 1.9 2005/10/03 12:29:21 scaekenberghe Exp $
 ;;;;
-;;;; Some tools to manipulate lxml
+;;;; Common utilities (mostly lxml) and some internal/experimental stuff
 ;;;;
 ;;;; Copyright (C) 2005 Sven Van Caekenberghe, Beta Nine BVBA. All Rights Reserved.
 ;;;;
@@ -47,7 +47,7 @@
   "Find all elements of a specific tag in a lxml XML DOM list"
   (remove-if-not #'(lambda (x) (eql (lxml-get-tag x) tag)) lxml))
 
-;;; internal 
+;;; internal shared/common code
 
 (defun actual-name (qname)
   "For now we ignore prefixes ;-)"
@@ -58,5 +58,54 @@
 
 (defun find-item-named (item-name sequence)
   (find (actual-name item-name) sequence :test #'string-equal :key #'get-name))
+
+;;; manipulating sexpr (structured/nested plists with string keys)
+
+(defun sexpr-getf (sexpr key &optional default)
+  "Find the value of key in sexpr (returning default if not found)"
+  (cond ((null sexpr) default)
+        ((consp sexpr) (let ((current-key (first sexpr)))
+                         (if (stringp current-key)
+                             (if (string-equal current-key key)
+                                 (second sexpr)
+                               (sexpr-getf (rest (rest sexpr)) key default))
+                           (error "Illegal key in sexpr: ~s" current-key))))
+        (t (error "Not an sexpr: ~s" sexpr))))
+
+(defun (setf sexpr-getf) (value sexpr key)
+  "Destructively modify the value of key in sexpr to value (add at tail if not found)"
+  (cond ((null sexpr) (error "Cannot destructively add to the empty list"))
+        ((consp sexpr) (let ((current-key (first sexpr)))
+                         (if (stringp current-key)
+                             (if (string-equal current-key key)
+                                 (setf (second sexpr) value)
+                               (if (null (rest (rest sexpr)))
+                                   (setf (rest (rest sexpr)) (list key value))
+                                 (setf (sexpr-getf (rest (rest sexpr)) key) value)))
+                           (error "Illegal key in sexpr: ~s" current-key))
+                         sexpr))
+        (t (error "Not an sexpr: ~s" sexpr))))
+
+(defun sexpr-select (sexpr keys)
+  "Return a new sexpr with keys and their values retained"
+  (cond ((null sexpr) '())
+        ((consp sexpr) (let ((current-key (first sexpr)))
+                         (if (stringp current-key)
+                             (if (member current-key keys :test #'string-equal)
+                                 `(,current-key ,(second sexpr) ,@(sexpr-select (rest (rest sexpr)) keys))
+                               (sexpr-select (rest (rest sexpr)) keys))
+                           (error "Illegal key in sexpr: ~s" current-key))))
+        (t (error "Not an sexpr: ~s" sexpr))))
+
+(defun sexpr-remove (sexpr keys)
+  "Return a new sexpr with keys and their values not retained"
+  (cond ((null sexpr) '())
+        ((consp sexpr) (let ((current-key (first sexpr)))
+                         (if (stringp current-key)
+                             (if (member current-key keys :test #'string-equal)
+                                 (sexpr-remove (rest (rest sexpr)) keys)
+                               `(,current-key ,(second sexpr) ,@(sexpr-remove (rest (rest sexpr)) keys)))
+                           (error "Illegal key in sexpr: ~s" current-key))))
+        (t (error "Not an sexpr: ~s" sexpr))))
 
 ;;;; eof