scsh-conservatory
/
sunterlib
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

initial SPAN

This commit is contained in:
erana 2012-01-18 00:15:03 +09:00
parent 1e5b4fdd6d
commit 902b798979
11 changed files with 295 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
scsh/SPAN/AUTHORS Normal file
View File

@ -0,0 +1 @@
Copyright (C) 2012 Johan Ceuppens

1
scsh/SPAN/BLURB Normal file
View File

@ -0,0 +1 @@
SPAN : Scheme Perl Archive Network

2
scsh/SPAN/NEWS Normal file
View File

@ -0,0 +1,2 @@
version 0.1
* client-server functionality

1
scsh/SPAN/README Normal file
View File

@ -0,0 +1 @@
A client-server system for getting scsh packages over the net.

38
scsh/SPAN/SPAN-client.scm Normal file
View File

@ -0,0 +1,38 @@
;;; client.scm - a full-duplex connect-to-server
;;;
;;; Copyright (c) 2011-2012 Johan Ceuppens
;;;
;;; All rights reserved.
;;;
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;; 1. Redistributions of source code must retain the above copyright
;;; notice, this list of conditions and the following disclaimer.
;;; 2. Redistributions in binary form must reproduce the above copyright
;;; notice, this list of conditions and the following disclaimer in the
;;; documentation and/or other materials provided with the distribution.
;;; 3. The name of the authors may not be used to endorse or promote products
;;; derived from this software without specific prior written permission.
;;;
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR
;;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
;;; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
;;; IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT,
;;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
;;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
;;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(define (ask-server request port-number)
(call-with-values
(lambda ()
(socket-client (get-host-name) port-number))
(lambda (in out)
(display request out)
(close-output-port out)
(let ((answer (make-string-input-port in))) ; returns any server response into some string
(close-input-port in)
answer))))

39
scsh/SPAN/SPAN-server.scm Normal file
View File

@ -0,0 +1,39 @@
;;; server.scm - a full-duplex connect-to-client
;;;
;;; Copyright (c) 2011-2012 Johan Ceuppens
;;;
;;; All rights reserved.
;;;
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;; 1. Redistributions of source code must retain the above copyright
;;; notice, this list of conditions and the following disclaimer.
;;; 2. Redistributions in binary form must reproduce the above copyright
;;; notice, this list of conditions and the following disclaimer in the
;;; documentation and/or other materials provided with the distribution.
;;; 3. The name of the authors may not be used to endorse or promote products
;;; derived from this software without specific prior written permission.
;;;
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR
;;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
;;; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
;;; IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT,
;;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
;;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
;;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(define (tell-client request port-number sock)
(call-with-values
(lambda ()
(socket-accept sock))
(lambda (in out)
(display request out)
(close-output-port out)
(let ((answer (make-string-input-port in))) ; returns any server response into some string
(close-input-port in)
answer)
)))

29
scsh/SPAN/SPAN.scm Normal file
View File

@ -0,0 +1,29 @@
;;; SPAN.scm - Scheme Perl Archive Network
;;;
;;; Copyright (c) 2011-2012 Johan Ceuppens
;;;
;;; All rights reserved.
;;;
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;; 1. Redistributions of source code must retain the above copyright
;;; notice, this list of conditions and the following disclaimer.
;;; 2. Redistributions in binary form must reproduce the above copyright
;;; notice, this list of conditions and the following disclaimer in the
;;; documentation and/or other materials provided with the distribution.
;;; 3. The name of the authors may not be used to endorse or promote products
;;; derived from this software without specific prior written permission.
;;;
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR
;;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
;;; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
;;; IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT,
;;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
;;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
;;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

28
scsh/SPAN/load.scm Normal file
View File

@ -0,0 +1,28 @@
;;; schemedoc.scm - a scheme perldoc utility
;;;
;;; Copyright (c) 2011-2012 Johan Ceuppens
;;;
;;; All rights reserved.
;;;
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;; 1. Redistributions of source code must retain the above copyright
;;; notice, this list of conditions and the following disclaimer.
;;; 2. Redistributions in binary form must reproduce the above copyright
;;; notice, this list of conditions and the following disclaimer in the
;;; documentation and/or other materials provided with the distribution.
;;; 3. The name of the authors may not be used to endorse or promote products
;;; derived from this software without specific prior written permission.
;;;
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR
;;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
;;; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
;;; IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT,
;;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
;;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
;;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

10
scsh/SPAN/packages.scm Normal file
View File

@ -0,0 +1,10 @@
(define-interface SPAN-interface
(export
make-SPAN-server
make-SPAN-client))
(define-structure SPAN
schemedoc-interface
(open scheme)
(files SPAN-client SPAN-server SPAN))

15
scsh/SPAN/pkg-def.scm Normal file
View File

@ -0,0 +1,15 @@
(define-package "SPAN"
(0 1)
((install-lib-version (1 3 0)))
(write-to-load-script
`((config)
(load ,(absolute-file-name "packages.scm"
(get-directory 'scheme #f)))))
(install-file "README" 'doc)
(install-file "NEWS" 'doc)
(install-string (COPYING) "COPYING" 'doc)
(install-file "packages.scm" 'scheme)
(install-file "client.scm" 'scheme)
(install-file "server.scm" 'scheme)
(install-file "load.scm" 'scheme)
(install-file "SPAN.scm" 'scheme))

131
scsh/SPAN/schemedoc.scm Normal file
View File

@ -0,0 +1,131 @@
;;; schemedoc.scm - a scheme perldoc utility
;;;
;;; Copyright (c) 2011-2012 Johan Ceuppens
;;;
;;; All rights reserved.
;;;
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;; 1. Redistributions of source code must retain the above copyright
;;; notice, this list of conditions and the following disclaimer.
;;; 2. Redistributions in binary form must reproduce the above copyright
;;; notice, this list of conditions and the following disclaimer in the
;;; documentation and/or other materials provided with the distribution.
;;; 3. The name of the authors may not be used to endorse or promote products
;;; derived from this software without specific prior written permission.
;;;
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR
;;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
;;; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
;;; IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT,
;;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
;;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
;;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(define (eoln)(string #\newline))
(define sod-regexp1 (rx (| "=item")))
(define (sod regexp filename)
(let ((in (open-input-file filename)))
(let ((contents ""))
(do ((s (read-char in)(read-char in)))
((eof-object? s) contents))
(string-match regexp contents))))
(define (schemedoc-print-doc filename)
(let ((l (list (sod (if (regexp? sod-regexp1)
sod-regexp1
(rx ("")))
filename))))
(for-each display l)))
(define (schemedoc-print-doc-to-file filename outfilename)
(let ((out (open-output-file outfilename)))
(let ((l (list (sod (if (regexp? sod-regexp1)
sod-regexp1
(rx ("")))
filename))))
(define (display-rec ll)
(do ((e ll (cdr e)))
((null? e)0)
(display (car e) out)))
(display-rec l))))
;;
;; parser :
;;
;; make a list of chars from filename contents
;;
(define (schemedoc-parser-doc filename)
(define (parse in)
(let ((c (read-char in)))
(if (eof-object? c)
c
(append (list c) (parse in)))))
(define (read-rec in)
(call-with-values
(lambda ()
(parse in)
)
(lambda (l)
;;(write l)
l)))
(let ((in (open-input-file filename))) ;; FIXME with-
(read-rec in)))
(define (schemedoc-parser-grep filename)
(let ((le (schemedoc-parser-doc filename))
(line "")
(headline "")
(itemlines '())
(itemtext "")
(itemtexts '())
)
(do ((l le (cdr l)))
((eof-object? l)0)
(cond ((and (eq? (car l) #\newline)(string<=? "=item" line))
(set! itemlines (append itemlines (list line)))
(set! line "")
(set! itemtexts (append itemtexts (list itemtext)))
(set! itemtext ""))
((and (eq? (car l) #\newline)(string<=? "=head" line))
(set! headline line)
(set! line ""))
;;((eq? (car l) #\newline)
)
(set! line (string-append line (string (car l))))
(set! itemtext (string-append itemtext (string (car l))))
)
itemtexts
))
(define (schemedoc-get-env-list SCHEMEDOCDIR)
(let ((directory "")
(directories '()))
(do ((i 0 (+ i 1)))
((>= i (string-length SCHEMEDOCDIR))
(set! directories (append directories (list directory))))
(if (eq? (string-ref SCHEMEDOCDIR i) #\:)
(begin
(set! directories (append directories (list directory)))
(set! directory "")))
(set! directory (string-append directory (string (string-ref SCHEMEDOCDIR i)))))
directories))
(define (schemedoc-parser-get-items keyword itemtexts)
(let ((returntext ""))
(do ((l itemtexts (cdr l)))
((null? l)0)
(cond ((string<=? keyword (car l))
(set! returntext (string-append returntext (car l))))))
returntext))