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

SPAN - client get command

This commit is contained in:
erana 2012-01-18 02:20:18 +09:00
parent 86b68d73bc
commit 94f7550f4f
4 changed files with 37 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
scsh/SPAN/SPAN-client.scm
View File

@ -1,6 +1,6 @@
;;; client.scm - a full-duplex connect-to-server ;;; client.scm - a full-duplex connect-to-server
;;; ;;;
;;; Copyright (c) 2011-2012 Johan Ceuppens ;;; Copyright (c) 2012 Johan Ceuppens
;;; ;;;
;;; All rights reserved. ;;; All rights reserved.
;;; ;;;
@ -26,10 +26,10 @@
;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
;;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(define (SPAN-ask-server request port-number) (define (SPAN-ask-server request hostname port)
(call-with-values (call-with-values
(lambda () (lambda ()
(socket-client (get-host-name) port-number)) (socket-client hostname port))
(lambda (in out) (lambda (in out)
(display request out) (display request out)
(close-output-port out) (close-output-port out)

2
scsh/SPAN/SPAN-server.scm
View File

@ -1,6 +1,6 @@
;;; server.scm - a full-duplex connect-to-client ;;; server.scm - a full-duplex connect-to-client
;;; ;;;
;;; Copyright (c) 2011-2012 Johan Ceuppens ;;; Copyright (c) 2012 Johan Ceuppens
;;; ;;;
;;; All rights reserved. ;;; All rights reserved.
;;; ;;;

2
scsh/SPAN/SPAN.scm
View File

@ -1,6 +1,6 @@
;;; SPAN.scm - Scheme Perl Archive Network ;;; SPAN.scm - Scheme Perl Archive Network
;;; ;;;
;;; Copyright (c) 2011-2012 Johan Ceuppens ;;; Copyright (c) 2012 Johan Ceuppens
;;; ;;;
;;; All rights reserved. ;;; All rights reserved.
;;; ;;;

40
scsh/SPAN/load.scm
View File

@ -1,6 +1,6 @@
;;; schemedoc.scm - a scheme perldoc utility ;;; load.scm - a scheme SPAN
;;; ;;;
;;; Copyright (c) 2011-2012 Johan Ceuppens ;;; Copyright (c) 2012 Johan Ceuppens
;;; ;;;
;;; All rights reserved. ;;; All rights reserved.
;;; ;;;
@ -27,9 +27,14 @@
;;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(load "SPAN.scm") (load "SPAN.scm")
(load "SPAN-client.scm")
;; initialization ;; initialization
;; Commands:
;; h : display help
;; get : fetch file
;; question 1 ;; question 1
(define SPAN-build-and-cache-dir (string-append (getenv "HOME") "/.span")) (define SPAN-build-and-cache-dir (string-append (getenv "HOME") "/.span"))
@ -147,10 +152,29 @@
#f)) #f))
(display SPAN-shell-droptext-22) (display SPAN-shell-droptext-22)
(do ((s (read)(read)) (define (url-bite-off url)
((and (symbol? s) (let ((s "")
(string<=? (symbol->string s)(string #\return))) (do ((i 0 (+ i 1)))
0) ((>= i (string-length url))
#t)) ;;(if (= (string-ref url i) #\/)
;; (set!
s)
(set! s (string-append s (string (string-ref url i)))))
(if (or (eq? s "http://")(eq? s "ftp://"))
(set! s "")))))
(display "Signing off - rest is under dev")) (do ((s (read)(read)))
((null? s)0)
(cond ((symbol? s)
(cond ((string<=? (symbol->string s)(string #\return))
0)
((string=? "h" (symbol->string s))
(display "Commands : get ")
0)
((string<=? "get" (symbol->string s))
(display "enter package to fetch : ")
(SPAN-ask-server (string-append "get " (symbol->string (read)))
(url-bite-off SPAN-mirror-url) 6969))
))
))
(display "Signing off.")