patches.lisp 2.56 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45
;;;; -*-Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
(in-package :cl-site)

;;
;; This file contains patches against depended-upon libraries. These
;; should be removed if/when the Quicklisp version of the libraries
;; are fixed.  Common-Lisp.Net policy dictates (or should dictate)
;; than any patches listed here have also been lodged as merge
;; requests or pull requests against the maintained repository of the
;; library in question.
;;


;;
;; CL-MARKDOWN patches.
;;
;; Merge Request has been lodged here:
;;
;;    https://gitlab.common-lisp.net/cl-markdown/cl-markdown/merge_requests/1
;;
;;   
;;
(in-package :cl-markdown)

(defextension (table-of-contents :arguments ((depth :required :keyword)
					     (start :required :keyword)
					     (label :keyword))
				  :insertp t)
  (ecase phase 
    (:parse
     (push (lambda (document)
	     (add-toc-anchors document :depth depth :start start))
	   (item-at-1 (properties *current-document*) :cleanup-functions))
     nil) 
    (:render
     (bind ((headers (collect-toc-headings depth start)))
       (when headers
	 (format *output-stream* 
		 "~&<a name='table-of-contents' id='table-of-contents'></a>")
	 (format *output-stream* "~&<div class='table-of-contents'>~%")
	 (when label
	   (format *output-stream* "<h1>~a</h1>" label))
	 (iterate-elements 
	  headers
	  (lambda (header)
46
	    (bind (((_ anchor text)
47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63
		    (item-at-1 (properties header) :anchor))
		   (save-header-lines (copy-list (lines header))))
	      (setf (slot-value header 'lines)
		    `(,(format nil
			       "~&<a href='~a~a' ~@[title='~a'~]>"
			       (if (char= (aref anchor 0) #\#) "" "#")
			       anchor
			       (encode-string-for-title text))
		       ,@(lines header)
		       ,(format nil "</a>")))
	      (render-to-html header nil)
	      (setf (slot-value header 'lines)
		    save-header-lines))))
	 (format *output-stream* "~&</div>~%"))))))

(defun render-handle-eval (body)
  ;;?? parse out commands and arguments (deal with quoting, etc)
64
  (bind (((command arguments result _) body)
65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83
         (result
          (cond ((and (member command *render-active-functions*)
                      (fboundp command))
                 (funcall command :render arguments (ensure-list result)))
		((and (member command *render-active-functions*)
		      (not (fboundp command)))
                 (warn "Undefined CL-Markdown function ~s" command))
                (t
                 nil))))
    (when result
      (output-html (list result))
      (setf *magic-space-p* nil)
      (setf *magic-line-p* -1))))

;;
;; end of CL-MARKDOWN patches. 
;;

(in-package :cl-site)