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

SPAN - client get command - 2

This commit is contained in:
erana 2012-01-18 03:10:44 +09:00
parent 94f7550f4f
commit 4843427027
2 changed files with 119 additions and 125 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
scsh/SPAN/SPAN.scm
View File

@ -42,8 +42,10 @@
(set! answer defaultchoice)) (set! answer defaultchoice))
((string=? (symbol->string s)(string #\return)) ((string=? (symbol->string s)(string #\return))
(set! answer defaultchoice)) (set! answer defaultchoice))
((string? (symbol->string s)) ((and (symbol? s)(string? (symbol->string s)))
(set! answer (symbol->string s))) (set! answer (symbol->string s)))
((and (number? s)(string? (number->string s)))
(set! answer (number->string s)))
(else (SPAN-question~ droptext question answer defaultchoice))) (else (SPAN-question~ droptext question answer defaultchoice)))
(procedure answer))) (procedure answer)))
@ -212,4 +214,5 @@ a valid CPAN URL now.
cpan shell -- CPAN exploration and modules installation (v1.9402) cpan shell -- CPAN exploration and modules installation (v1.9402)
Enter 'h' for help.") Enter 'h' for help.")

237
scsh/SPAN/load.scm
View File

@ -26,6 +26,7 @@
;;; (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.
(load "SPAN-util.scm")
(load "SPAN.scm") (load "SPAN.scm")
(load "SPAN-client.scm") (load "SPAN-client.scm")
@ -35,146 +36,136 @@
;; h : display help ;; h : display help
;; get : fetch file ;; get : fetch file
(define answer "")
;; 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"))
(define SPAN-download-target-dir (string-append (getenv "HOME") "/.span")) (define SPAN-download-target-dir (string-append (getenv "HOME") "/.span"))
;;prototype (define (SPAN-question~ droptext question answer defaultchoice) (define SPAN-mirror-url "ask")
(SPAN-question~ SPAN-shell-droptext-1
"SPAN build and cache directory"
""
SPAN-build-and-cache-dir
(lambda (answer)
(let ((dir (create-directory answer)))
(if (file-directory? dir)
(set! SPAN-build-and-cache-dir answer)
#f))))
(define SPAN-download-target-dir (string-append SPAN-build-and-cache-dir "/" "sources") (cond
(SPAN-question~ SPAN-shell-droptext-2 ((and (file-exists? SPAN-build-and-cache-dir)
"Download target directory" (file-exists? (string-append SPAN-build-and-cache-dir "/mirror")))
"" (let ((SPAN-mirror-url (make-string-input-port
SPAN-download-target-dir (open-input-file (string-append SPAN-build-and-cache-dir "/mirror")))))
(lambda (answer) (SPAN-shell-spawn SPAN-mirror-url)))
(let ((dir (create-directory answer))) (else
(if (file-directory? answer) ;;prototype (define (SPAN-question~ droptext question answer defaultchoice)
(set! SPAN-download-target-dir answer) (SPAN-question~ SPAN-shell-droptext-1
#f)))) "SPAN build and cache directory"
""
SPAN-build-and-cache-dir
(lambda (answer)
(let ((dir (create-directory answer)))
(if (file-directory? dir)
(set! SPAN-build-and-cache-dir answer)
#f))))
(define SPAN-build-dir (string-append SPAN-build-and-cache-dir "/" "build") (define SPAN-download-target-dir (string-append SPAN-build-and-cache-dir "/" "sources"))
(SPAN-question~ SPAN-shell-droptext-3 (SPAN-question~ SPAN-shell-droptext-2
"Directory where the build process takes place?" "Download target directory"
"" ""
SPAN-download-target-dir SPAN-download-target-dir
(lambda (answer) (lambda (answer)
(let ((dir (create-directory answer))) (let ((dir (create-directory answer)))
(if (file-directory? answer) (if (file-directory? answer)
(set! SPAN-download-target-dir answer)
#f))))
(define SPAN-build-dir (string-append SPAN-build-and-cache-dir "/" "build"))
(SPAN-question~ SPAN-shell-droptext-3
"Directory where the build process takes place?"
""
SPAN-download-target-dir
(lambda (answer)
(let ((dir (create-directory answer)))
(if (file-directory? answer)
(set! SPAN-build-dir answer) (set! SPAN-build-dir answer)
#f)))) #f))))
(define SPAN-config "no") (define SPAN-config "no")
(SPAN-question~ SPAN-shell-droptext-4 (SPAN-question~ SPAN-shell-droptext-4
"Always commit changes to config variables to disk?" "Always commit changes to config variables to disk?"
"" ""
SPAN-config SPAN-config
(lambda (answer) (lambda (answer)
(set! SPAN-config answer) (set! SPAN-config answer)
#f)) #f))
(define SPAN-build-Mb 100) (define SPAN-build-Mb 100)
(SPAN-question~ SPAN-shell-droptext-5 (SPAN-question~ SPAN-shell-droptext-5
"Cache size for build directory (in MB)?" "Cache size for build directory (in MB)?"
"" ""
SPAN-build-Mb SPAN-build-Mb
(lambda (answer) (lambda (answer)
(set! SPAN-build-Mb answer) (set! SPAN-build-Mb answer)
#f)) #f))
(define SPAN-expire 1) (define SPAN-expire 1)
(SPAN-question~ SPAN-shell-droptext-6 (SPAN-question~ SPAN-shell-droptext-6
"Let the index expire after how many days?" "Let the index expire after how many days?"
"" ""
SPAN-expire SPAN-expire
(lambda (answer) (lambda (answer)
(set! SPAN-expire answer) (set! SPAN-expire answer)
#f)) #f))
(define SPAN-scan-cache "atstart") (define SPAN-scan-cache "atstart")
(SPAN-question~ SPAN-shell-droptext-7 (SPAN-question~ SPAN-shell-droptext-7
"Perform cache scanning (atstart or never)?" "Perform cache scanning (atstart or never)?"
"" ""
SPAN-scan-cache SPAN-scan-cache
(lambda (answer) (lambda (answer)
(set! SPAN-scan-cache answer) (set! SPAN-scan-cache answer)
#f)) #f))
(define SPAN-cache-metadata "yes") (define SPAN-cache-metadata "yes")
(SPAN-question~ SPAN-shell-droptext-8 (SPAN-question~ SPAN-shell-droptext-8
"Cache metadata (yes/no)?" "Cache metadata (yes/no)?"
"" ""
SPAN-cache-metadata SPAN-cache-metadata
(lambda (answer) (lambda (answer)
(set! SPAN-cache-metadata answer) (set! SPAN-cache-metadata answer)
#f)) #f))
(define SPAN-policy-building "ask") (define SPAN-policy-building "ask")
(SPAN-question~ SPAN-shell-droptext-9 (SPAN-question~ SPAN-shell-droptext-9
"Policy on building prerequisites (follow, ask or ignore)? [ask]" "Policy on building prerequisites (follow, ask or ignore)? [ask]"
"" ""
SPAN-policy-building SPAN-policy-building
(lambda (answer) (lambda (answer)
(set! SPAN-policy-building answer) (set! SPAN-policy-building answer)
#f)) #f))
;; question 10 is under dev ;; question 10 is under dev
;; question 11 is under dev ;; question 11 is under dev
;; question 12 is under dev ;; question 12 is under dev
;; question 13 is under dev ;; question 13 is under dev
;; ... until 20 ;; ... until 20
(define SPAN-mirror-url "ask")
(SPAN-question~ SPAN-shell-droptext-20
"Please enter the URL of your CPAN mirror "
""
SPAN-mirror-url
(lambda (answer)
(set! SPAN-mirror-url answer)
#f))
(define SPAN-mirror-url-2 "") (SPAN-question~ SPAN-shell-droptext-20
(SPAN-question~ SPAN-shell-droptext-21 "Please enter the URL of your CPAN mirror "
"Enter another URL or RETURN to quit: [] " ""
"" SPAN-mirror-url
SPAN-mirror-url-2 (lambda (answer)
(lambda (answer) (set! SPAN-mirror-url answer)
(set! SPAN-mirror-url-2 answer) (let ((out (open-output-file (string-append SPAN-build-and-cache-dir "/mirror"))))
#f)) (write answer out))
#f))
(display SPAN-shell-droptext-22) (define SPAN-mirror-url-2 "")
(define (url-bite-off url) (SPAN-question~ SPAN-shell-droptext-21
(let ((s "") "Enter another URL or RETURN to quit: [] "
(do ((i 0 (+ i 1))) ""
((>= i (string-length url)) SPAN-mirror-url-2
;;(if (= (string-ref url i) #\/) (lambda (answer)
;; (set! (set! SPAN-mirror-url-2 answer)
s) #f))
(set! s (string-append s (string (string-ref url i)))))
(if (or (eq? s "http://")(eq? s "ftp://")) (display SPAN-shell-droptext-22)
(set! s ""))))) (SPAN-shell-spawn SPAN-mirror-url))
))
(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.")