arnesi

HTTP/HTML utilities 

URIs/URLs 

(defvar *ok-set* '(#\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m #\n #\o #\p
                   #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z
                   #\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M #\N #\O #\P[...]
                   #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z
                   #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9
                   #\. #\,))

(defun escape-as-uri (string)
  "Escapes all non alphanumeric characters in STRING following
  the URI convention. Returns a fresh string."
  (with-output-to-string (escaped)
    (write-as-uri string escaped)))

(defun write-as-uri (string stream)
  (loop
     for char across string
     if (member char *ok-set*) do (write-char char stream)
     else do (format stream "%~2,'0X" (char-code char))))

(defun char->hex-value (char)
  "Returns the number associated the hex value of CHAR. CHAR must
  be one of #\0 - #\9, #\a - #\f, #\A - #\F."[...]
  (ecase char
    (#\0 0) (#\1 1) (#\2 2) (#\3 3) (#\4 4) (#\5 5) (#\6 6) (#\7 7) (#\8 8) (#\9 9)
    ((#\a #\A) 10)
    ((#\b #\B) 11)
    ((#\c #\C) 12)
    ((#\d #\D) 13)
    ((#\e #\E) 14)
    ((#\f #\F) 15)))

(defun make-escaped-table ()
  (let ((table (make-array '(16 16) :element-type 'character :initial-element #\\)))
    (dotimes (i 16)[...]
      (dotimes (j 16)
        (setf (aref table i j) (code-char (+ (* i 16) j)))))
    table))

(defvar *unescape-table* (make-escaped-table))

(defun nunescape-as-uri (string)
  (unescape-as-uri string))

(defun unescape-as-uri (string)
  (with-output-to-string (unescaped)
    (loop[...]
       for index upfrom 0
       while (< index (length string)) 
       do (case (aref string index)
	    (#\% (write-char (aref *unescape-table*
				   (char->hex-value (aref string (incf index)))
				   (char->hex-value (aref string (incf index))))
			     unescaped))
	    (#\+ (write-char #\Space unescaped))
	    (t (write-char (aref string index) unescaped))))))

HTML 

(defun make-html-entities ()
  (let ((ht (make-hash-table :test 'equal)))
    (flet ((add-mapping (char escaped)[...]
             (setf (gethash char ht) escaped
                   (gethash escaped ht) char)))
      (add-mapping #\< "&lt;")
      (add-mapping #\> "&gt;")
      (add-mapping #\& "&amp;")
      (add-mapping #\" "&quot;")
      (add-mapping "a`" "&#224;")
      (add-mapping "a'" "&#225;")
      (add-mapping "e`" "&#232;")
      (add-mapping "e'" "&#233;")
      (add-mapping "i'" "&#236;")
      (add-mapping "i`" "&#237;")
      (add-mapping "o`" "&#242;")
      (add-mapping "o'" "&#243;")
      (add-mapping "u`" "&#249;")
      (add-mapping "u'" "&#250;"))
    ht))

(defparameter *html-entites* (make-html-entities))

(defun write-as-html (string &key (stream t) (escape-whitespace nil))
  (loop
     for char across string[...]
     do (cond
          ((char= char #\Space)
           (if escape-whitespace
               (princ " " stream)
               (write-char char stream)))
          ((gethash char *html-entites*)
           (princ (gethash char *html-entites*) stream))
          ((> (char-code char) 127)
           (princ "&#x" stream)
           (write (char-code char) :stream stream :base 16)
           (write-char #\; stream))
          (t (write-char char stream)))))

(defun escape-as-html (string &key (escape-whitespace nil))
  (with-output-to-string (escaped)
    (write-as-html string :stream escaped :escape-whitespace escape-whitespace)))

(define-condition html-escape-error (error)
  ((what :accessor html-escape-error.what :initarg :what)))

(define-condition unterminated-html-entity (html-escape-error)
  ())

(define-condition unknown-html-entity (html-escape-error)
  ())

(define-condition unknown-char-escape (warning)
  ((what :accessor html-escape-error.what :initarg :what)))

(defun unescape-as-html (string)
  (with-output-to-string (unescaped)
    (loop[...]
       for offset upfrom 0 below (length string)
       for char = (aref string offset)
       if (char= #\& char)
         do (progn
              (aif (position #\; string :start offset)
                   (let ((escape-tag (subseq string offset (1+ it))))
                     (aif (gethash escape-tag *html-entites*)
                          (progn
                            (princ it unescaped)
                            (incf offset (1- (length escape-tag))))
                          (if (char= #\# (aref escape-tag 1))
                              ;; special code, ignore
                              (restart-case
                                  (warn 'unknown-char-escape :what escape-tag)
                                (continue-delete ()
                                  :report "Continue processing, delete this char."
                                  (incf offset (1- (length escape-tag)))))
                              (restart-case
                                  (error 'unknown-html-entity :what escape-tag)
                                (continue-as-is ()
                                  :report "Continue processing, leaving the string as is."
                                  (write-char #\& unescaped))
                                (continue-delete ()
                                  :report "Continue processing, delete this entity."
                                  (incf offset (1- (length escape-tag))))))))
                   (restart-case
                       (error 'unterminated-html-entity
                              :what (subseq string offset
                                            (min (+ offset 20)
                                                 (length string))))
                     (continue-as-is ()
                       :report "Continue processing, leave the string as is."
                       (write-char #\& unescaped)))))
       else do (write-char char unescaped))))