diff --git a/cl-icalendar.asd b/cl-icalendar.asd index 8fca556..5e45515 100644 --- a/cl-icalendar.asd +++ b/cl-icalendar.asd @@ -28,7 +28,7 @@ :name "iCalendar library" :license "GPLv3+" :version "0.0" - :depends-on (:trivial-gray-streams :cl-base64 :uuid :flexi-streams) + :depends-on (:trivial-gray-streams :cl-base64 :uuid :babel) :serial t :components ((:static-file "COPYING") diff --git a/cl-icalendar.lisp b/cl-icalendar.lisp index 2813a88..963f7d4 100644 --- a/cl-icalendar.lisp +++ b/cl-icalendar.lisp @@ -21,7 +21,7 @@ (in-package :cl-icalendar) (defun open-vcalendar (pathname) - (with-open-file (infile pathname :element-type '(unsigned-byte 8)) + (with-open-file (infile pathname :element-type :default) (with-folding-stream (in infile) (read-vcalendar in)))) diff --git a/components.lisp b/components.lisp index aa45d46..583d45f 100644 --- a/components.lisp +++ b/components.lisp @@ -58,8 +58,7 @@ (declare (ignorable initargs)))) (defun make-uninitialized-component (name) - (let* ((name (string-upcase name)) - (component-class (find-component-class name))) + (let* ((component-class (find-component-class name))) (allocate-component component-class name))) (defun make-component (name &rest initargs) @@ -290,8 +289,8 @@ ;;; CLHS says: "If a defclass form appears as a top level form, the ;;; compiler must make the class name be recognized as a valid type ;;; name in..." So we have to define the classes separately. -(defmacro declare-component (name) - `(defclass ,name (standard-component) nil)) +(defmacro declare-component (name &optional abstract-components) + `(defclass ,name (,@abstract-components standard-component) nil)) ;;; Define a component. (defmacro define-component (name options &body body) diff --git a/content-line.lisp b/content-line.lisp index 410545d..badd646 100644 --- a/content-line.lisp +++ b/content-line.lisp @@ -23,9 +23,9 @@ (defun read-params-value (stream) (if (char= (peek-char nil stream) #\") (prog2 (read-char stream) - (parse stream "#\"" #\newline) + (parse stream "#\"" #.(string #\newline)) (read-char stream)) - (string-upcase (parse stream ",;:" #\Newline)))) + (string-upcase (parse stream ",;:" #.(string #\Newline))))) (defun read-params-values (stream) (unlist @@ -38,7 +38,7 @@ (defun read-params (stream) (with-collect (while (char= (read-char stream) #\;) - (let ((name (parse stream "=" (coerce #(#\Newline #\: #\;) 'string)))) + (let ((name (parse stream "=" #.(coerce #(#\Newline #\: #\;) 'string)))) (read-char stream) (collect (string-upcase name)) (collect (read-params-values stream)))))) @@ -50,7 +50,7 @@ (char= ch #\space) (char= ch #\tab)) do (read-char stream)) - (values (parse stream ";:" #\Newline) + (values (string-upcase (parse stream ";:" #.(string #\Newline))) (read-params stream) (read-line stream))) diff --git a/folding.lisp b/folding.lisp index 6c48fd5..b5c276a 100644 --- a/folding.lisp +++ b/folding.lisp @@ -20,16 +20,10 @@ (in-package :cl-icalendar) -;;; FIXME: flexi-streams requires a binary (or bivalent) stream. We -;;; would like to avoid this restriction. - (defconstant +tab-character+ (code-char #x09)) (defconstant +content-line-max-length+ 75) -;;; We build folding-stream upon flexi-streams. They are supposed to -;;; implement CRLF end of line style and UTF-8 encoding. Column octets -;;; counting is implemented by folding-stream. (defclass folding-stream (fundamental-character-input-stream fundamental-character-output-stream) ((column-octets @@ -38,13 +32,12 @@ :reader folding-column-octets) (backend-stream :initform (required-arg) - :type flex:flexi-stream + :type stream :initarg :stream :reader folding-backend-stream))) (defun make-folding-stream (stream) - (let ((fs (flex:make-flexi-stream stream :external-format '(:utf-8 :eol-style :crlf)))) - (make-instance 'folding-stream :stream fs))) + (make-instance 'folding-stream :stream stream)) (defmacro with-folding-stream ((var stream) &body code) `(with-open-stream (,var (make-folding-stream ,stream)) @@ -56,15 +49,19 @@ (defmethod stream-read-char ((stream folding-stream)) (with-slots (backend-stream) stream - (let ((character (stream-read-char backend-stream))) + (let ((character (read-char backend-stream))) (cond ((eq character :eof) :eof) + ;; #\return #\newline => #\newline + ((char= character #\return) + (when (eql (peek-char nil backend-stream nil) #\newline) + (stream-read-char stream))) ((and (char= character #\newline) (linear-whitespace-p (peek-char nil backend-stream nil #\A))) ;; Skip the newline from folding algorithm and go on. - (stream-read-char backend-stream) - (stream-read-char backend-stream)) + (read-char backend-stream) + (read-char backend-stream)) (t character))))) @@ -73,16 +70,19 @@ (defmethod stream-write-char ((stream folding-stream) character) (with-slots (column-octets backend-stream) stream - (let* ((external-format (flex:flexi-stream-external-format backend-stream)) - (size (flex:octet-length (string character) :external-format external-format))) - (when (> (+ column-octets size) +content-line-max-length+) - (stream-write-char backend-stream #\newline) - (stream-write-char backend-stream #\space) - (zerof column-octets)) - (if (char= character #\newline) - (zerof column-octets) - (incf column-octets size)) - (stream-write-char backend-stream character)))) + (let* ((encoded (babel:string-to-octets + (if (char= character #\newline) + #.(coerce '(#\return #\linefeed) 'string) + (string character)))) + (size (length encoded))) + (when (> (+ column-octets size) +content-line-max-length+) + (stream-write-char stream #\newline) + (stream-write-char stream #\space) + (zerof column-octets)) + (if (char= character #\linefeed) + (zerof column-octets) + (incf column-octets size)) + (write-sequence encoded backend-stream)))) (defmethod stream-line-column ((stream folding-stream)) (stream-line-column (folding-backend-stream stream))) diff --git a/parameters.lisp b/parameters.lisp index 5d8e34f..c130df4 100644 --- a/parameters.lisp +++ b/parameters.lisp @@ -29,7 +29,7 @@ ;;; Get the value of the parameter, whose name is given in the string ;;; designator PARAMETER, in the given PARAMETER-LIST. (defun parameter (parameter parameter-list) - (let ((name (string-upcase (string parameter)))) + (let ((name (string parameter))) (loop for (param value) on parameter-list by #'cddr when (string= name param) return value))) diff --git a/translate.lisp b/translate.lisp index 23b9fbd..073f890 100644 --- a/translate.lisp +++ b/translate.lisp @@ -43,22 +43,21 @@ (defun register-translation (object icalname entity) (with-slots (ical>lisp lisp>ical) (intern-translation-table entity) - (let ((icalname (string-upcase icalname))) - ;; Remove old associations for OBJECT and ICALNAME. - (let ((oldlisp (gethash icalname ical>lisp)) - (oldical (gethash object lisp>ical))) - (remhash oldlisp lisp>ical) - (remhash oldical ical>lisp)) - ;; Set new associations - (setf (gethash icalname ical>lisp) object) - (setf (gethash object lisp>ical) icalname) - (values)))) + ;; Remove old associations for OBJECT and ICALNAME. + (let ((oldlisp (gethash icalname ical>lisp)) + (oldical (gethash object lisp>ical))) + (remhash oldlisp lisp>ical) + (remhash oldical ical>lisp)) + ;; Set new associations + (setf (gethash icalname ical>lisp) object) + (setf (gethash object lisp>ical) icalname) + (values))) ;;; Translate the iCalendar name ICALNAME to a corresponding Lisp ;;; object in the ENTITY namespace. (defun translate-to-lisp (icalname entity) (with-slots (ical>lisp) (intern-translation-table entity) - (values (gethash (string-upcase icalname) ical>lisp)))) + (values (gethash icalname ical>lisp)))) ;;; Translate the Lisp value OBJECT to the corresponding iCalendar ;;; name in the ENTITY namespace. diff --git a/universal-time.lisp b/universal-time.lisp index d3c7bcb..4fe3a6a 100644 --- a/universal-time.lisp +++ b/universal-time.lisp @@ -36,7 +36,7 @@ ;;; Decode a universal time. (defmacro decoded-universal-time - ((&key second minute hour date month year day zone) + ((&key second minute hour date month year day zone (timezone nil timezone-p)) form &body body) (let ((vars)) (flet ((** (x) (or x (car (push (gensym) vars))))) @@ -44,7 +44,9 @@ (,(** second) ,(** minute) ,(** hour) ,(** date) ,(** month) ,(** year) ,(** day) ,(** zone)) - (decode-universal-time ,form) + ,(if timezone-p + `(decode-universal-time ,form ,timezone) + `(decode-universal-time ,form)) (declare (ignore ,@vars)) ,@body)))) diff --git a/utils.lisp b/utils.lisp index ee3f6b6..d0e2a3d 100644 --- a/utils.lisp +++ b/utils.lisp @@ -318,27 +318,42 @@ ;;; it finds a NON-EXPECT character, it signals an error. If an end of ;;; file condition is signaled and EOF-ERROR-P is nil, return nil. (defun parse (stream char-bag &optional (not-expect "") (eof-error-p t)) - (flet (;; Check if CH is a terminal char - (terminal-char-p (ch) + (declare (optimize speed)) + (flet ((in (ch char-bag) + ;; Check if CH is in CHAR-BAG. (etypecase char-bag (character (char= ch char-bag)) - (sequence (find ch char-bag :test #'char=)) - (function (funcall char-bag ch)))) - ;; Check if CH is not an expected char - (not-expect-char-p (ch) - (etypecase not-expect - (character (char= ch not-expect)) - (sequence (find ch not-expect :test #'char=)) - (function (funcall not-expect ch))))) + (sequence (find ch char-bag)) + (function (funcall char-bag ch))))) ;; Read characters (with-output-to-string (out) (loop for ch = (peek-char nil stream eof-error-p) until (and (not eof-error-p) (null ch)) - until (terminal-char-p ch) - when (not-expect-char-p ch) + until (in ch char-bag) + when (in ch not-expect) do (error "Character ~w is not expected." ch) do (write-char (read-char stream) out))))) +;;; An optimized version of `parse' specific for calls where +;;; `char-bag' and `not-expected' are simple strings. +(defun parse-simple (stream char-bag &optional (not-expect "") (eof-error-p t)) + (declare (optimize speed) + (simple-string char-bag not-expect) + (boolean eof-error-p)) + ;; Read characters + (with-output-to-string (out) + (loop for ch = (peek-char nil stream eof-error-p) + until (and (not eof-error-p) (null ch)) + until (find (the character ch) char-bag) + when (find (the character ch) not-expect) + do (error "Character ~w is not expected." ch) + do (write-char (read-char stream) out)))) + +(define-compiler-macro parse (&whole form stream char-bag &optional (not-expect "") (eof-error-p t)) + (if (and (stringp char-bag) (stringp not-expect)) + `(parse-simple ,stream ,char-bag ,not-expect ,eof-error-p) + form)) + ;;;; Comparators @@ -350,7 +365,6 @@ ;;; Like `string=' but it is case-insensitive. (defun string-ci= (str1 str2) - (declare (string str1 str2)) (and (= (length str1) (length str2)) (every #'char-ci= str1 str2))) @@ -394,7 +408,8 @@ ;;; Like `parse-integer' but it is not allowed to have a sign (+\-). (defun parse-unsigned-integer (string &rest keyargs &key (start 0) end &allow-other-keys) - (unless (or (eql start end) (digit-char-p (elt string start))) + (declare (string string)) + (unless (or (eql start end) (digit-char-p (char string start))) (error "~w is not an unsigned integer." string)) (apply #'parse-integer string keyargs))