utils-ldif.lisp

   1 (in-package :ldif)
   2
   3 ;;; was in package toys:
   4 (defmacro do-reader ((var reader &optional result) &body body)
   5   (let ((read-label (gensym))
   6         (eof-error (gensym)))
   7     `(block do-read
   8        (tagbody
   9           ,read-label
  10           (handler-case
  11               (let ((,var ,reader))
  12                 ,@body)
  13             (end-of-file (,eof-error)
  14               (declare (ignore ,eof-error))
  15               (return-from do-read ,result)))
  16           (go ,read-label)))))
  17
  18 ;;; was in package toys:
  19 (defmacro map-reader (function reader)
  20   (let ((value (gensym))
  21         (collector (gensym)))
  22     `(let (,collector)
  23        (do-reader (,value ,reader (nreverse ,collector))
  24          (push (funcall ,function ,value)
  25                ,collector)))))
  26
  27 ;;; records
  28
  29 (defun record-distinguished-name (record)
  30   "Return the distinguished name (DN) of the record as a string."
  31   (car record))
  32
  33 (defun record-object-classes (record)
  34   "Return a list of the object classes of the record in the same format as attributes.
  35 The ATTRIBUTE-* functions will operate successfully on the elements of this list."
  36   (cadr record))
  37
  38 (defun record-attributes-list (record)
  39   "Returns a list of the attributes of this record."
  40   (caddr record))
  41
  42 (defun record-attributes (record attribute-name)
  43   "Returns a list of the attributes named by ATTRIBUTE-NAME."
  44   (cdr (assoc attribute-name (record-attributes-list record)
  45               :test #'string-equal)))
  46
  47 (defun record-attribute (record attribute-name &key (nil-errorp nil))
  48   "Returns a single attribute named by ATTRIBUTE-NAME.
  49 An error is thrown if RECORD contains multiple values for this attribute.
  50 The argument NIL-ERRORP controls behavior if no attributes match ATTRIBUTE-NAME;
  51 if false, NIL is returned; if true, an error is signalled."
  52   (let ((attributes (record-attributes record attribute-name)))
  53     (cond
  54       ((> (length attributes) 1) (error "Multiple attributes for ~S" attribute-name))
  55       ((= (length attributes) 1) (car attributes))
  56       (nil-errorp (error "Attribute ~S not found" attribute-name)))))
  57
  58 (defun (setf record-attribute) (new-attribute record attribute-name &key (nil-errorp nil))
  59   "Sets a single attribute named by ATTRIBUTE-NAME to new-attribute.
  60 An error is thrown if RECORD contains multiple values for this attribute.
  61 The argument NIL-ERRORP controls behavior if no attributes match ATTRIBUTE-NAME;
  62 if false, NIL is returned; if true, an error is signalled."
  63   (let ((attributes (record-attributes record attribute-name)))
  64     (cond
  65       ((> (length attributes) 1) (error "Multiple attributes for ~S" attribute-name))
  66       ((= (length attributes) 1) (setf (car attributes) new-attribute))
  67       (nil-errorp (error "Attribute ~S not found" attribute-name)))))
  68
  69 (defun record-attribute-value (record attribute &key (nil-errorp nil))
  70   "Finds a single attribute as by RECORD-ATTRIBUTE, and returns its value.
  71 The attribute's options are returned as a secondary value."
  72   (with-accessors ((options attribute-options)
  73                    (value attribute-value))
  74       (record-attribute record attribute :nil-errorp nil-errorp)
  75     (values value options)))
  76
  77 (defun (setf record-attribute-value) (new-value record attribute &key (nil-errorp nil))
  78   "Finds a single attribute as by RECORD-ATTRIBUTE, and sets its value to new-value."
  79   (with-accessors ((options attribute-options)
  80                    (value attribute-value))
  81       (record-attribute record attribute :nil-errorp nil-errorp)
  82     (setf value new-value)))
  83
  84
  85 ;;; change records
  86
  87 (defun change-record-change-type (record)
  88   "Returns the change type of the change record RECORD.
  89 This will be a symbol in the LDIF package."
  90   (cadr record))
  91
  92
  93 ;;; attributes
  94
  95 (defun attribute-options (attribute)
  96   "Returns a list of strings denoting ATTRIBUTE's options."
  97   (car attribute))
  98
  99 (defun attribute-value (attribute)
 100   "Returns the string value of ATTRIBUTE."
 101   (cadr attribute))
 102
 103 (defun (setf attribute-value) (new-value attribute)
 104   "Set the string value of ATTRIBUTE."
 105   (setf (cadr attribute) new-value))