read.lisp

   1 (in-package :clldap)
   2
   3 (defvar *line-number*)
   4
   5 (defun continuation-line-p (line)
   6   (and (not (zerop (length line)))
   7        (eql (elt line 0) #\Space)))
   8
   9 (defun parse-ldif-line (line)
  10   (cond
  11     ((null line) nil)
  12     ((zerop (length line)) 'separator)
  13     ((eql (elt line 0) #\#) (values 'comment (string-left-trim " " (subseq line 1))))
  14     ((continuation-line-p line) (values 'continuation (subseq line 1))) ; should never happen
  15     (t
  16      (let ((colon-pos (position #\: line)))
  17        (cond ((null colon-pos)
  18               (error "Missing #\: in ~S." line))
  19              ((<= (length line) (1+ colon-pos))
  20               (let ((attribute-description (split-sequence #\; (subseq line 0 colon-pos))))
  21                 (list (car attribute-description) (cdr attribute-description) "")))
  22              (t
  23               (let ((content (case (elt line (1+ colon-pos))
  24                                (#\: (base64-string-to-string (string-left-trim " " (subseq line (+ 2 colon-pos)))))
  25                                (#\< (error "URL attribute values not supported."))
  26                                (t (string-left-trim " " (subseq line (1+ colon-pos))))))
  27                     (attribute-description (split-sequence #\; (subseq line 0 colon-pos))))
  28                 (list (car attribute-description) (cdr attribute-description) content))))))))
  29
  30 (defun read-cleansed-line (stream)
  31   (let ((line (read-line stream)))
  32     (when line
  33       (string-right-trim '(#\Return #\Newline) line))))
  34
  35 (defun separator-line-p (line)
  36   (zerop (length line)))
  37
  38 (defun read-raw-ldif (stream)
  39   (let (working-line
  40         results
  41         (line-number (if (boundp '*line-number*) *line-number* 1)))
  42     (macrolet ((current-results ()
  43                  `(if working-line
  44                       (cons (parse-ldif-line working-line) results)
  45                       results)))
  46       (do-reader (line (read-cleansed-line stream)
  47                             (or (nreverse (current-results))
  48                                 (error 'end-of-file
  49                                        :stream stream)))
  50         (if (continuation-line-p line)
  51             (if working-line
  52                 (setf working-line (concatenate 'string working-line (subseq line 1)))
  53                 (error "Attempt to continue at start of record on ~:[record ~;~]line ~D."
  54                        (boundp '*line-number*) line-number))
  55             (if (separator-line-p line)
  56                 (return-from read-raw-ldif (nreverse (current-results)))
  57                 (setf results (current-results)
  58                       working-line line
  59                       line-number (1+ line-number))))))))
  60
  61 (defun line-name (line)
  62   (car line))
  63
  64 (defun line-options (line)
  65   (cadr line))
  66
  67 (defun line-value (line)
  68   (caddr line))
  69
  70 (defun raw-ldif->record (ldif)
  71   (let (distinguished-name
  72         object-classes
  73         attributes)
  74     (dolist (line ldif
  75              (list distinguished-name (nreverse object-classes) (nreverse attributes)))
  76       (cond
  77         ((eq line 'comment))
  78         ((string-equal (car line) "dn")
  79          (cond
  80            ((line-options line)
  81             (error "Options not allowed for distinguished name."))
  82            (distinguished-name
  83             (error "Distinguished name already declared."))
  84            (t
  85             (setf distinguished-name (line-value line)))))
  86         ((string-equal (car line) "objectclass")
  87          (if distinguished-name
  88              (setf object-classes (cons (cdr line) object-classes))
  89              (error "Distinguished name not declared.")))
  90         (t
  91          (if distinguished-name
  92              (let ((attribute-values (assoc (line-name line) attributes
  93                                             :test #'string-equal)))
  94                (if attribute-values
  95                    (setf (cdr attribute-values)
  96                          (append (cdr attribute-values)
  97                                  (list (cdr line))))
  98                    (push (list (car line) (cdr line)) attributes)))
  99              (error "Distinguished name not declared.")))))))
 100
 101 (defun read-record (&optional (stream *standard-input*) (eof-error-p t) eof-value)
 102   "Reads a single LDIF data record from STREAM."
 103   (raw-ldif->record (handler-case
 104                         (read-raw-ldif stream)
 105                       (end-of-file (e)
 106                         (if eof-error-p
 107                             (error e)
 108                             (return-from read-record eof-value))))))
 109
 110 (defun parse-ldif-stream (stream)
 111   "Returns a list of data records read from STREAM up to end-of-file."
 112   (map-reader 'raw-ldif->record (read-raw-ldif stream)))
 113
 114 (defun parse-ldif-file (pathname)
 115   "Returns a list of data records read from the file designated by PATHNAME."
 116   (with-open-file (ldif pathname)
 117     (parse-ldif-stream ldif)))