+++ /dev/null
-#| -*-Scheme-*-
-
-This code is written by Taylor R. Campbell and placed in the Public
-Domain.
-
-|#
-
-;;;; Lisppaste XML-RPC Interface
-
-;;; For details, see
-;;; <http://paste.lisp.org/>
-;;; <http://common-lisp.net/project/lisppaste/>
-
-(declare (usual-integrations))
-
-(load-option 'XML)
-\f
-;;;; Paste Creation and Annotation
-
-(define (lisppaste-insert-paste paste-number #!optional annotation-number)
- (let ((entry (lisppaste:paste-details paste-number annotation-number)))
- (if (command-argument)
- (show-lisppaste entry (mark->output-port (current-point)))
- (insert-string (lisppaste-entry/content entry)))))
-
-(define-command lisppaste-insert-paste
- "Insert the numbered paste at the point.
-With a prefix argument, also show a header describing the paste."
- "nPaste number"
- lisppaste-insert-paste)
-
-(define-command lisppaste-insert-annotation
- "Insert the annotation of the numbered paste at the point.
-With a prefix argument, also show a header describing the annotation."
- (lambda ()
- (let* ((paste-number (maybe-prompt-for-lisppaste-number #f))
- (annotation-number (prompt-for-lisppaste-annotation-number)))
- (list paste-number annotation-number)))
- lisppaste-insert-paste)
-
-(define (lisppaste-create channel nickname title content)
- (message-or-pop-up (lisppaste:new-paste channel nickname title content)))
-
-(define-command lisppaste-buffer
- "Create a new paste of the current buffer."
- (lambda ()
- (read-lisppaste-creation-arguments))
- (lambda (channel nickname title)
- (lisppaste-create channel nickname title
- (buffer-string (current-buffer)))))
-
-(define-command lisppaste-region
- "Create a new paste of the current region."
- (lambda ()
- (cons (current-region) (read-lisppaste-creation-arguments)))
- (lambda (region channel nickname title)
- (lisppaste-create channel nickname title (region->string region))))
-
-(define (read-lisppaste-creation-arguments)
- (let ((argument (command-argument)))
- (let* ((channel (maybe-prompt-for-lisppaste-channel argument))
- (nickname (maybe-prompt-for-lisppaste-nickname argument))
- (title (prompt-for-lisppaste-title)))
- (list channel nickname title))))
-
-(define (lisppaste-annotate number nickname title content)
- (message-or-pop-up
- (lisppaste:new-paste
- (lisppaste-entry/channel (lisppaste:paste-header number))
- nickname
- title
- content
- number)))
-
-(define-command lisppaste-annotate-with-buffer
- "Annotate an existing paste with the current buffer."
- (lambda ()
- (read-lisppaste-annotation-arguments))
- (lambda (number nickname title)
- (lisppaste-annotate number nickname title
- (buffer-string (current-buffer)))))
-
-(define-command lisppaste-annotate-with-region
- "Annotate an existing paste with the region."
- (lambda ()
- (cons (current-region) (read-lisppaste-annotation-arguments)))
- (lambda (region number nickname title)
- (lisppaste-annotate number nickname title
- (region->string region))))
-
-(define (read-lisppaste-annotation-arguments)
- (let ((argument (command-argument)))
- (let* ((number (maybe-prompt-for-lisppaste-number argument))
- (nickname (maybe-prompt-for-lisppaste-nickname argument))
- (title (prompt-for-lisppaste-annotation-title)))
- (list number nickname title))))
-\f
-;;;; Paste Listing
-
-(define-command lisppaste-channels
- "List all the channels supported by lisppaste in a temporary buffer."
- ()
- (lambda ()
- (call-with-output-to-temporary-buffer " *lisppaste channels*"
- '(READ-ONLY SHRINK-WINDOW FLUSH-ON-SPACE)
- (lambda (port)
- (write-strings-densely (lisppaste:list-channels) port)))))
-
-(define (lisppaste-list-pastes entries)
- (call-with-output-to-temporary-buffer " *lisppastes*"
- '(READ-ONLY SHRINK-WINDOW FLUSH-ON-SPACE)
- (lambda (port)
- (for-each (lambda (entry)
- (show-lisppaste entry port))
- entries))))
-
-(define-command lisppaste-list-pastes
- "List the headers of the last number of pastes.
-With a prefix argument, list pastes starting at a certain number."
- (lambda ()
- (read-lisppaste-listing-arguments))
- (lambda (count #!optional start-number)
- (lisppaste-list-pastes
- (lisppaste:paste-headers count start-number))))
-
-(define-command lisppaste-list-channel-pastes
- "List the headers of the last few pastes in a certain channel.
-With a prefix argument, list pastes starting at a certain number."
- (lambda ()
- (let ((channel (maybe-prompt-for-lisppaste-channel #t)))
- (cons channel (read-lisppaste-listing-arguments))))
- (lambda (channel start-number #!optional count)
- (lisppaste-list-pastes
- (lisppaste:paste-headers-by-channel channel start-number count))))
-
-(define (read-lisppaste-listing-arguments)
- (let ((count (prompt-for-number "Number of pastes to list" #f)))
- (cond ((command-argument)
- => (lambda (argument)
- (list count
- (if (command-argument-multiplier-only? argument)
- (prompt-for-number "Starting paste" #f)
- (command-argument-numeric-value argument)))))
- (else (list count)))))
-
-(define (show-lisppaste entry #!optional port)
- (let ((port
- (if (default-object? port)
- (current-output-port)
- (guarantee textual-output-port? port 'SHOW-LISPPASTE))))
- (receive (number time author channel title annotations content)
- (lisppaste-entry/components entry)
- (write-string "Paste " port)
- (write number port)
- (write-string " in " port)
- (write-string channel port)
- (write-string " by " port)
- (write-string author port)
- (write-string " at " port)
- (write-string (decoded-time->iso8601-string time) port)
- (newline port)
- (write-string " " port)
- (write-string title port)
- (if (positive? annotations)
- (begin
- (newline port)
- (write-string " (" port)
- (write annotations port)
- (write-string " annotations)" port)))
- (newline port)
- (newline port)
- (if content (write-string content port)))))
-\f
-;;;; Argument Reading
-
-(define lisppaste-last-channel #f)
-
-(define (lisppaste-default-channel)
- (or lisppaste-last-channel
- (ref-variable lisppaste-default-channel)))
-
-(define (maybe-prompt-for-lisppaste-channel argument)
- ((lambda (channel)
- (set! lisppaste-last-channel channel)
- channel)
- (or (and (not argument)
- (lisppaste-default-channel))
- (prompt-for-lazy-string-table-name
- "Channel"
- (lisppaste-default-channel)
- (delay
- (alist->string-table
- (map (lambda (channel-name)
- (cons channel-name #f))
- (lisppaste:list-channels))))
- 'CASE-INSENSITIVE-COMPLETION? #t))))
-
-(define lisppaste-last-nickname #f)
-
-(define (lisppaste-default-nickname)
- (or lisppaste-last-nickname
- (ref-variable lisppaste-default-nickname)))
-
-(define (maybe-prompt-for-lisppaste-nickname argument)
- ((lambda (nickname)
- (set! lisppaste-last-nickname nickname)
- nickname)
- (or (and (not argument)
- (lisppaste-default-nickname))
- (prompt-for-string "Nickname"
- (lisppaste-default-nickname)))))
-
-(define (prompt-for-lisppaste-title)
- (prompt-for-string "Title"
- ;; No default string
- #f))
-
-(define (prompt-for-lisppaste-annotation-title)
- (prompt-for-lisppaste-title))
-
-(define lisppaste-last-number #f)
-
-(define (lisppaste-default-number)
- lisppaste-last-number)
-
-(define (maybe-prompt-for-lisppaste-number argument)
- ((lambda (number)
- (set! lisppaste-last-number number)
- number)
- (or (and argument
- (not (command-argument-multiplier-only? argument))
- (command-argument-numeric-value argument))
- (prompt-for-number "Paste number"
- (lisppaste-default-number)))))
-
-(define lisppaste-last-annotation-number #f)
-
-(define (lisppaste-default-annotation-number)
- lisppaste-last-annotation-number)
-
-(define (prompt-for-lisppaste-annotation-number)
- ((lambda (number)
- (set! lisppaste-last-annotation-number number)
- number)
- (prompt-for-number "Annotation number"
- (lisppaste-default-annotation-number))))
-\f
-;;;; Lisppaste RPC
-
-;;; This could be used outside of Edwin if it made no reference to the
-;;; Edwin variable LISPPASTE-RPC-URI or the procedure EDITOR-ERROR.
-
-(define (lisppaste-rpc method-name required-arguments optional-argument)
- (let ((result
- (xml-rpc (ref-variable lisppaste-rpc-uri)
- (lisppaste-request method-name
- required-arguments
- optional-argument))))
- (if (and (string? result)
- (string-prefix? "Error" result))
- (editor-error result)
- result)))
-
-(define (lisppaste-request method-name required-arguments optional-argument)
- (make-xml-document (make-xml-declaration "1.0" "UTF-8" #f)
- '() ;misc-1
- #f ;DTD
- '() ;misc-2
- (apply xml-rpc:request method-name
- (if (and (not (default-object? optional-argument))
- optional-argument)
- (append required-arguments
- (list optional-argument))
- required-arguments))
- '())) ;misc-3
-
-(define (lisppaste:new-paste channel nickname title content
- #!optional number-of-paste-to-annotate)
- (lisppaste-rpc "newpaste" (list channel nickname title content)
- number-of-paste-to-annotate))
-
-(define (lisppaste:paste-header number)
- (car (lisppaste:paste-headers 1 number)))
-
-(define (lisppaste:paste-headers count #!optional start-number)
- (lisppaste-rpc "pasteheaders" (list count)
- start-number))
-
-(define (lisppaste:paste-headers-by-channel channel count
- #!optional start-number)
- (lisppaste-rpc "pasteheadersbychannel" (list channel count)
- start-number))
-
-(define (lisppaste:paste-annotation-headers paste-number)
- (lisppaste-rpc "pasteannotationheaders" (list paste-number)
- #f))
-
-(define (lisppaste:paste-details paste-number #!optional annotation-number)
- (lisppaste-rpc "pastedetails" (list paste-number)
- annotation-number))
-
-(define (lisppaste:list-channels)
- (lisppaste-rpc "listchannels" '() #f))
-
-(define (lisppaste-entry/number entry) (list-ref entry 0))
-(define (lisppaste-entry/time entry) (list-ref entry 1))
-(define (lisppaste-entry/nickname entry) (list-ref entry 2))
-(define (lisppaste-entry/channel entry) (list-ref entry 3))
-(define (lisppaste-entry/title entry) (list-ref entry 4))
-(define (lisppaste-entry/annotations entry) (list-ref entry 5))
-(define (lisppaste-entry/content entry)
- (if (> (length entry) 6)
- (list-ref entry 6)
- #f))
-
-(define (lisppaste-entry/components entry)
- (values (lisppaste-entry/number entry)
- (lisppaste-entry/time entry)
- (lisppaste-entry/nickname entry)
- (lisppaste-entry/channel entry)
- (lisppaste-entry/title entry)
- (lisppaste-entry/annotations entry)
- (lisppaste-entry/content entry)))
-\f
-;;;; Random Utilities
-
-(define (prompt-for-lazy-string-table-name prompt
- default-string
- string-table-promise
- . options)
- (apply prompt-for-completed-string
- prompt
- default-string
- (lambda (string if-unique if-not-unique if-not-found)
- (string-table-complete (force string-table-promise)
- string
- if-unique
- if-not-unique
- if-not-found))
- (lambda (string)
- (string-table-completions (force string-table-promise) string))
- (lambda (string)
- (let ((default (list 'DEFAULT)))
- (not (eq? (string-table-get (force string-table-promise)
- string
- (lambda (index) index default))
- default))))
- options))
-
-(define (message-or-pop-up string)
- (if (and (not (string-find-next-char string #\newline))
- (let ((tab-width (ref-variable tab-width #f))
- (char-image-strings (ref-variable char-image-strings #f)))
- (< (string-columns string 0 tab-width char-image-strings)
- (window-x-size (typein-window)))))
- (message string)
- (string->temporary-buffer string
- " *lisppaste*"
- '(READ-ONLY SHRINK-WINDOW FLUSH-ON-SPACE))))
projects / mit-scheme.git / commitdiff