From: Taylor R. Campbell Date: Sat, 4 Nov 2006 20:25:17 +0000 (+0000) Subject: New Edwin library: a front end for lisppaste, using its XML-RPC interface. X-Git-Tag: 20090517-FFI~847 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=58eaecba7fd3d36a8800c51a02d91c0df2692208;p=mit-scheme.git New Edwin library: a front end for lisppaste, using its XML-RPC interface. See for details. --- diff --git a/v7/src/edwin/decls.scm b/v7/src/edwin/decls.scm index ba0befdba..31f74a32d 100644 --- a/v7/src/edwin/decls.scm +++ b/v7/src/edwin/decls.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: decls.scm,v 1.77 2006/10/25 17:29:21 cph Exp $ +$Id: decls.scm,v 1.78 2006/11/04 20:25:17 riastradh Exp $ Copyright 1989,1990,1991,1992,1993,1994 Massachusetts Institute of Technology Copyright 1995,1996,1997,1998,1999,2000 Massachusetts Institute of Technology @@ -166,6 +166,7 @@ USA. "kmacro" "lincom" "linden" + "lisppaste" "loadef" "lspcom" "malias" diff --git a/v7/src/edwin/ed-ffi.scm b/v7/src/edwin/ed-ffi.scm index dc3b302ad..5276d152c 100644 --- a/v7/src/edwin/ed-ffi.scm +++ b/v7/src/edwin/ed-ffi.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: ed-ffi.scm,v 1.55 2006/06/26 16:16:18 riastradh Exp $ +$Id: ed-ffi.scm,v 1.56 2006/11/04 20:25:17 riastradh Exp $ Copyright 1990,1991,1992,1993,1994,1995 Massachusetts Institute of Technology Copyright 1996,1997,1998,1999,2000,2001 Massachusetts Institute of Technology @@ -105,6 +105,7 @@ USA. ("kmacro" (edwin)) ("lincom" (edwin)) ("linden" (edwin lisp-indentation)) + ("lisppaste" (edwin lisppaste)) ("loadef" (edwin)) ("lspcom" (edwin)) ("macros" (edwin macros)) diff --git a/v7/src/edwin/lisppaste.scm b/v7/src/edwin/lisppaste.scm new file mode 100644 index 000000000..e1a807650 --- /dev/null +++ b/v7/src/edwin/lisppaste.scm @@ -0,0 +1,350 @@ +#| -*-Scheme-*- + +$Id: lisppaste.scm,v 1.1 2006/11/04 20:25:17 riastradh Exp $ + +This code is written by Taylor R. Campbell and placed in the Public +Domain. + +|# + +;;;; Lisppaste XML-RPC Interface + +;;; For details, see +;;; +;;; + +(declare (usual-integrations)) + +(load-option 'XML) + +;;;; 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 (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 (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)))) + +;;;; 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*" + '(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*" + '(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) + (begin + (guarantee-output-port port 'SHOW-LISPPASTE) + port)))) + (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))))) + +;;;; 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)))) + +;;;; Lisppaste RPC + +;;; This could be used outside of Edwin if it made no reference to the +;;; Edwin variable LISPPASTE-RPC-URI. + +(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)) + (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))) + +;;;; Random Utility + +(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)) diff --git a/v7/src/edwin/loadef.scm b/v7/src/edwin/loadef.scm index 3052685f4..27ff5c511 100644 --- a/v7/src/edwin/loadef.scm +++ b/v7/src/edwin/loadef.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: loadef.scm,v 1.49 2006/06/16 19:02:27 riastradh Exp $ +$Id: loadef.scm,v 1.50 2006/11/04 20:25:17 riastradh Exp $ Copyright 1986,1989,1990,1991,1992,1993 Massachusetts Institute of Technology Copyright 1994,1995,1996,1997,1998,1999 Massachusetts Institute of Technology @@ -350,6 +350,57 @@ This is usually 103 or 2627." ;;; **************** +(define-library 'LISPPASTE + '("lisppaste" (EDWIN LISPPASTE))) + +(define-autoload-command 'lisppaste-channels 'LISPPASTE + "List all the channels supported by lisppaste in a temporary buffer.") + +(define-autoload-command 'lisppaste-insert-paste 'LISPPASTE + "Insert the numbered paste at the point. +With a prefix argument, also show a header describing the paste.") + +(define-autoload-command 'lisppaste-insert-annotation 'LISPPASTE + "Insert the annotation of the numbered paste at the point. +With a prefix argument, also show a header describing the annotation.") + +(define-autoload-command 'lisppaste-buffer 'LISPPASTE + "Create a new paste of the current buffer.") + +(define-autoload-command 'lisppaste-region 'LISPPASTE + "Create a new paste of the current region.") + +(define-autoload-command 'lisppaste-annotate-with-buffer 'LISPPASTE + "Annotate an existing paste with the current buffer.") + +(define-autoload-command 'lisppaste-annotate-with-region 'LISPPASTE + "Annotate an existing paste with the region.") + +(define-autoload-command 'lisppaste-list-pastes 'LISPPASTE + "List the headers of the last number of pastes. +With a prefix argument, list pastes starting at a certain number.") + +(define-autoload-command 'lisppaste-list-channel-pastes 'LISPPASTE + "List the headers of the last few pastes in a certain channel. +With a prefix argument, list pastes starting at a certain number.") + +(define-variable lisppaste-rpc-uri + "URI of the lisppaste XML-RPC service." + "http://common-lisp.net:8185/RPC2" + ->uri) + +(define-variable lisppaste-default-channel + "Default channel for lisppaste requests." + #f + string?) + +(define-variable lisppaste-default-nickname + "Default IRC nickname for lisppaste requests." + #f + string?) + +;;; **************** + (define-library 'PASSWORD-EDIT '("pwedit" (EDWIN PASSWORD-EDIT)) '("pwparse" (EDWIN PASSWORD-EDIT)))