CL-HTTP and Zmacs killring

It took me a while to figure out accessing the killring in Zmacs.
I wrote some example code to access the killring from a web browser.
You can get an item from the killring, all items and you can
push to the killring.  This allows exchanging text with the
Zmacs killring of a remote Lisp Machine, even if something like
the X11 clipboard isn't working. You might want to protect the URLs  
against
random use.

URLs are:   /killring/get?n (n being a number) , /killring/getall and / 
killring/push


Maybe somebody finds it useful. The example:

;;; ----------------------------------------------------------------
;;; Kill ring integration of CL-HTTP and Zmacs

(defun respond-killring-get (url stream)
   (let ((args (url:search-keys url)))
     (unless args (setf args '("0")))
     (let ((n (parse-integer (first args))))
       (http:with-successful-response (stream :text)
	(princ (killring-history-string n) stream )))))

(defun respond-killring-get-all (url stream)
   (declare (ignore url))
   (http:with-successful-response (stream :text)
     (loop for string in (all-killring-strings)
	  for i from 0
	  do (princ i stream)
	  do (terpri stream)
	  do (princ string stream)
	  do (terpri stream)
	  do (princ "---------------------------------------------------"  
stream)
	  do (terpri stream))))

(defun interval-as-string (interval)
   (zwei:string-interval (scl:send interval :first-bp) (scl:send  
interval :last-bp)))
			
(defun killring-history-string (&optional (n 0))
   (assert (< n (scl:send zwei:*kill-history* :length)) (n))
   (let ((element (scl:send zwei:*kill-history* :element n)))
     (if (stringp element)
	element
	(interval-as-string element))))

(defun all-killring-strings ()
   (loop for i below (scl:send zwei:*kill-history* :length)
	for element = (scl:send zwei:*kill-history* :element i)
	collect (if (stringp element) element (interval-as-string element))))

(http:export-url #u"/killring/get?"
		 :search
		 :response-function 'respond-killring-get)

(http:export-url #u"/killring/get-all"
		 :computed
		 :response-function 'respond-killring-get-all)

(defun respond-to-killring-post (url stream alist)
   (let ((push-string (assoc "push" alist :key #'string :test  
#'equalp)))
     (when push-string (setf push-string (second push-string)))
     (if (and push-string (stringp push-string))
	(progn
	  (scl:send zwei:*kill-history* :push push-string)
	  (compute-killring-push-form url stream push-string))
	(compute-killring-push-form url stream))))

(defun compute-killring-push-form (url stream &optional (default ""))
   (declare (ignore url))
   (http:with-successful-response (stream :html)
     (html:with-html-document (:stream stream)
       (html:with-document-preamble (:stream stream)
	(html:declare-title "Push text onto killring of RJNXP Home" :stream  
stream))
       (html:with-document-body (:stream stream)
	(html:with-fillout-form (:post "/killring/push" :stream stream)
	  (princ "Push this text onto the killring" stream)
	  (terpri stream)
	  (html:break-line :stream stream)
	  (html:accept-input 'html:multi-line-text "push" :rows 6 :columns  
50 :default default :stream stream)
	  (html:break-line :stream stream)
	  (html:break-line :stream stream)
	  (html:accept-input 'html:submit-button "submit" :stream stream))))))

(http:export-url #u"/killring/push"
		 :computed-form
		 :form-function 'compute-killring-push-form
		 :response-function 'respond-to-killring-post)



Rainer Joswig, Hamburg, Germany
http://lispm.dyndns.org/
mailto:[email protected]




_______________________________________________
WWW-CL mailing list
[email protected]
https://lists.csail.mit.edu/mailman/listinfo/www-cl