-- J.P. Larocque: piranha@thoughtcrime.us, piranha@ely.ath.cx ;;; These are the efficient, albeit hairy and micro-optimized versions ;;; of ESCAPE-BYTES and SQL-ESCAPE-STRING. ;;; These functions were tested on the following implementations. ;;; Rates are from the measurement of (SQL-ESCAPE-STRING (ESCAPE-BYTES ;;; v)), without OPTIMIZE declarations, where v is a vector of ;;; 10,000,000 random octets, on a 2GHz Athlon64. ;;; SBCL 0.9.16 x86_64: 860,807 octets/sec ;;; OpenMCL 1.1-pre-070512 LinuxX8664: 627,077 octets/sec ;;; CLISP 2.41 x86_64: 18,243 octets/sec ;;; (To its credit, CLISP used under 100MiB of RAM, where the ;;; others used over ~200MiB.) (defmacro defencoder (name &key get-length set-string documentation (prefix "") (suffix "") (element-type t) (character-type 'character)) "Defines a function of the given NAME which encodes an input vector to a string. The resulting string always starts with the contents of PREFIX and always ends with the contents of SUFFIX. Each element of the defined function's input is mapped to zero or more characters by the given GET-LENGTH and SET-STRING functions. GET-LENGTH takes one argument, an element, and returns the number of characters required to encode it. SET-STRING takes three arguments--an element, a string, and a position--which is required to write the encoded form of the element to the given string at the given position, and then return the number of characters written. This unfortunately low-level interface was selected to avoid consing and slow implementations of WITH-OUTPUT-TO-STRING. The type of the elements of the input vector may be specified with ELEMENT-TYPE. The resulting string will be a subtype of `(VECTOR ,CHARACTER-TYPE). When CHARACTER-TYPE is supplied, SET-STRING must write only characters of that type." (when (or (null get-length) (null set-string)) (error "Must supply :GET-LENGTH and :SET-STRING.")) `(let ((get-length-fn ,get-length) (set-string-fn ,set-string) (prefix ,prefix) (suffix ,suffix)) (defun ,name (input-vec) ,@(if (null documentation) '() `(,documentation)) (let* ((output-length (+ (loop :for element :of-type ,element-type :across input-vec :sum (funcall get-length-fn element)) (length prefix) (length suffix))) (output (make-array output-length :element-type ',character-type ;; #\Space for lack of something better. :initial-element #\Space)) (output-pos 0)) (flet ((add-string (s) (setf (subseq output output-pos (+ output-pos (length s))) s) (incf output-pos (length s)))) (add-string prefix) (loop :for element :of-type ,element-type :across input-vec :for written-count := (funcall set-string-fn element output output-pos) :do (incf output-pos written-count)) (add-string suffix)) output)))) (defencoder escape-bytes :documentation "Escape an array of octets in PostgreSQL's horribly inefficient textual format for binary data." ;; STANDARD-CHAR contains backslash, digits, and all the ASCII ;; characters we pass unescaped. :element-type (unsigned-byte 8) :character-type standard-char :get-length (lambda (byte) (if (or (< byte 32) (> byte 126) (= byte 39) (= byte 92)) 4 ; "\ooo" 1)) :set-string (lambda (byte s start) (cond ((or (< byte 32) (> byte 126) (= byte 39) (= byte 92)) ;; Write "\ooo". (let ((place64 (floor byte 64)) (place8 (mod (floor byte 8) 8)) (place1 (mod byte 8))) (setf (elt s (+ start 0)) #\) (setf (elt s (+ start 1)) (digit-char place64 8)) (setf (elt s (+ start 2)) (digit-char place8 8)) (setf (elt s (+ start 3)) (digit-char place1 8)) 4)) (t (setf (elt s start) (code-char byte)) 1)))) (defencoder sql-escape-string :documentation "Escape string data so it can be used in a query." :prefix "'" :suffix "'" :element-type character :get-length (lambda (char) (if (member char '(#' #\) :test #'char=) 2 ; "''" or "\\", respectively. 1)) :set-string (lambda (char s start) (case char (#' ;; Write "''". (setf (elt s start) #') (setf (elt s (1+ start)) #') 2) (#\ ;; Write "\\". Turn off postgres' backslash ;; behaviour to prevent unexpected strangeness. (setf (elt s start) #\) (setf (elt s (1+ start)) #\) 2) (t (setf (elt s start) char) 1)))) ;;; These versions--the originals--take quadratic time on SBCL, ;;; because of WITH-OUTPUT-TO-STRING. That's SBCL's fault; with ;;; OpenMCL, the time is linear. (defun escape-bytes-orig (bytes) "Escape an array of octets in PostgreSQL's horribly inefficient textual format for binary data." (with-output-to-string (out) (loop :for byte :of-type fixnum :across bytes :do (if (or (< byte 32) (> byte 126) (= byte 39) (= byte 92)) (format out "\~3,'0o" byte) (princ (code-char byte) out))))) (defun sql-escape-string-orig (string) "Escape string data so it can be used in a query." (with-output-to-string (out) (princ #' out) (loop :for char :of-type character :across string :do (princ (case char (#' "''") ;; Turn off postgres' backslash behaviour to ;; prevent unexpected strangeness. (#\ "\\") (t char)) out)) (princ #' out))) ;;; Some utility functions for comparing the above. (defun time-escape-function (escape-f input-vec) (let* ((start-real-time (get-internal-real-time)) (start-run-time (get-internal-run-time)) (test-result (time (funcall escape-f input-vec)))) (let* ((end-real-time (get-internal-real-time)) (end-run-time (get-internal-run-time)) (real-time (/ (- end-real-time start-real-time) internal-time-units-per-second)) (run-time (/ (- end-run-time start-run-time) internal-time-units-per-second)) (real-time-rate (unless (zerop real-time) (/ (length input-vec) real-time))) (run-time-rate (unless (zerop run-time) (/ (length input-vec) run-time)))) (format t "Real time: ~,1F (~,1F elt/sec)~%Run time: ~,1F (~,1F elt/sec)~%" real-time real-time-rate run-time run-time-rate) test-result))) (defun compare-escape-functions (input-size &rest escape-functions) (let ((test-vec (make-array `(,input-size) :element-type '(unsigned-byte 8) :initial-element 0)) last-result) (loop for i from 0 below input-size doing (setf (elt test-vec i) (random 256))) (dolist (escape-function escape-functions) (format t "~S:~%" escape-function) (let ((result (time-escape-function escape-function test-vec))) (unless (null last-result) (if (equalp result last-result) (format t "Results match.~%") (format t "*** Results do not match.~%"))) (terpri) (setf last-result result)))) (values)) (defvar *failed-vector* nil ;; We have this because the failing vector might be huge and too ;; cumbersome for a condition or result value to a REPL. "The last vector that failed within TEST-ESCAPE-FUNCTIONS.") (defun test-escape-functions (type initial-element key elt-upper-bound escape-f-1 escape-f-2) (labels ((test-vector (vector desc &rest arguments) (let ((result1 (funcall escape-f-1 vector)) (result2 (funcall escape-f-2 vector))) (unless (equalp result1 result2) (setf *failed-vector* vector) (error "~S and ~S return different results for: ~?" escape-f-1 escape-f-2 desc arguments))))) (test-vector (make-array 0 :element-type type) "empty vector") (loop :for len :from 1 :below 10 :do (loop :for i :from 0 :below elt-upper-bound :for elt := (funcall key i) :do (unless (null elt) (let ((vector (make-array len :element-type type :initial-element elt))) (test-vector vector "length ~D with element ~S" len elt))))) (loop :for len := (random 10) :for vector := (make-array len :element-type type :initial-element initial-element) :repeat 25 :do (loop :for i :from 0 :below len :for elt := (loop :for eltx := (funcall key (random elt-upper-bound)) :while (null eltx) :finally (return eltx)) :doing (setf (elt vector i) elt)) :do (test-vector vector "~D random element~:P" len)))) ;;; On Lisp, 5.4: Composing Functions (defun compose (&rest functions) (if (endp functions) #'identity (let ((function1 (car (last functions))) (functions (butlast functions))) (lambda (&rest args) (reduce #'funcall functions :from-end t :initial-value (apply function1 args)))))) (defun run-tests () (format t "Testing ESCAPE-BYTES{,-ORIG}.~%") (test-escape-functions '(unsigned-byte 8) 0 #'identity 256 #'escape-bytes #'escape-bytes-orig) ;; Cap at 64K to avoid going through 1M+ Unicode characters. (format t "Testing SQL-ESCAPE-STRING{,-ORIG}.~%") (test-escape-functions 'character #\Space #'code-char (min char-code-limit 65536) #'sql-escape-string #'sql-escape-string-orig) (format t "Testing the composition of SQL-ESCAPE-STRING ESCAPE-BYTES with ...-ORIG.~%") (test-escape-functions '(unsigned-byte 8) 0 #'identity 256 (compose #'sql-escape-string #'escape-bytes) (compose #'sql-escape-string-orig #'escape-bytes-orig)) (format t "No problems to report."))