Skip to content
Branch: master
Find file Copy path
Find file Copy path
Fetching contributors…
Cannot retrieve contributors at this time
143 lines (124 sloc) 5.12 KB
;;;; © Michał "phoe" Herda 2016
;;;; safe-read.lisp
;; Lisp reader hackery below. Beware.
(in-package #:safe-read)
;; Exported conditions and parameters
(define-condition incomplete-input () ())
(define-condition malformed-input (error) ())
(define-condition input-size-exceeded (error) ())
(defvar *max-input-size* (* 128 1024))
;; Utility functions
(defun condition-key (condition)
(intern (string (type-of condition)) (find-package :keyword)))
(defun whitespace-p (char)
(member char '(#\Space #\Newline #\Backspace #\Tab
#\Linefeed #\Page #\Return #\Rubout)))
(defun trim-leading-whitespace (string)
(let ((whitespace '(#\Space #\Newline #\Backspace #\Tab
#\Linefeed #\Page #\Return #\Rubout)))
(string-left-trim whitespace string)))
;; Buffers for streams
(defvar *stream-buffers* (make-weak-hash-table :weakness :key))
(defun buffer-of (stream)
(check-type stream stream)
(or (gethash stream *stream-buffers*) ""))
(defun (setf buffer-of) (new-value stream)
(if (or (null new-value) (string= new-value ""))
(remhash stream *stream-buffers*)
(setf (gethash stream *stream-buffers*) new-value)))
;; Utility macro - temporary packages
(defmacro with-temp-package (&body body)
(let* ((now (format nil "~S" (local-time:now)))
(package-name (gensym (uiop:strcat "TEMP-PKG-" now "-")))
(package-var (gensym)))
`(let ((,package-var (or (find-package ',package-name)
(make-package ',package-name :use nil))))
(unwind-protect (let ((*package* ,package-var)) ,@body)
(delete-package ,package-var)))))
;; Utility macro - creating a safe readtable at compile-time
(eval-when (:compile-toplevel :load-toplevel :execute)
(defparameter %safe-readtable% (copy-readtable))
(defparameter %max-safe-char% 256)
(let ((*readtable* %safe-readtable%))
(flet ((signal-malformed-input (stream char)
(declare (ignore stream char))
(error 'malformed-input))
(eat-colon (stream char)
(declare (ignore char))
(if (eq #\: (read-char-no-hang stream))
(read stream)
(error 'malformed-input))))
(dotimes (i %max-safe-char%)
(let* ((char (code-char i))
(macro-char (get-macro-character char)))
(unless (or (null char)
(member char '(#\( #\) #\"))
(null macro-char))
(set-macro-character char #'signal-malformed-input))))
(set-macro-character #\: #'signal-malformed-input)
(set-macro-character #\# #'eat-colon))))
;; Main exported function
(defun safe-read (&optional (stream *standard-input*))
(let ((buffer (buffer-of stream)))
(if (string= "" buffer)
(safe-read-no-buffer stream)
(safe-read-buffer stream))
(incomplete-input ()
(values nil :incomplete-input))
(end-of-file (e)
(error e))
(error (error)
(setf (buffer-of stream) "")
(error error)))))
;; Handler-case and macro-wrapper for safe reading
(defmacro safe-read-handler-case (&body body)
(let ((gensym (gensym)))
(let* ((*readtable* %safe-readtable%)
(,gensym (progn ,@body)))
(setf (buffer-of stream) "")
(values ,gensym nil))
(end-of-file ()
(unless (string= line "")
(setf (buffer-of stream)
(uiop:strcat (buffer-of stream) line (string #\Newline))))
(signal (make-condition 'incomplete-input)))
(malformed-input (e)
(setf (buffer-of stream) "")
(signal e))))))
;; Safe read - no buffer
(defun safe-read-no-buffer (stream)
(let ((line (trim-leading-whitespace (read-limited-line stream))))
(read-from-string line))))
;; Safe read - buffer
(defun safe-read-buffer (stream)
(let* ((buffer (buffer-of stream))
(line (read-limited-line stream (length buffer))))
(read-from-string (uiop:strcat buffer line)))))
;; Reading from string with a maximum size limit
(defun read-limited-line (&optional (stream *standard-input*) (buffer-length 0))
(with-output-to-string (result)
(let ((char-counter buffer-length) char)
(setf char (read-char-no-hang stream nil :eof))
(cond ((null char)
((eq char #\Newline)
((and (eq char :eof) (= 0 char-counter))
(error 'end-of-file :stream stream))
((and (eq char :eof) (/= 0 char-counter))
((and (= 0 buffer-length) (= 0 char-counter) (whitespace-p char))
((and (= 0 buffer-length) (= 0 char-counter) (char/= #\( char))
(error (make-condition 'malformed-input)))
((< *max-input-size* (incf char-counter))
(error (make-condition 'input-size-exceeded)))
(t (princ char result)))))))
You can’t perform that action at this time.