From 484342702778ed935cfd17889140e22bd2e8ac58 Mon Sep 17 00:00:00 2001 From: erana Date: Wed, 18 Jan 2012 03:10:44 +0900 Subject: [PATCH] SPAN - client get command - 2 --- scsh/SPAN/SPAN.scm | 7 +- scsh/SPAN/load.scm | 237 ++++++++++++++++++++++----------------------- 2 files changed, 119 insertions(+), 125 deletions(-) diff --git a/scsh/SPAN/SPAN.scm b/scsh/SPAN/SPAN.scm index bc94e01..01af919 100644 --- a/scsh/SPAN/SPAN.scm +++ b/scsh/SPAN/SPAN.scm @@ -42,8 +42,10 @@ (set! answer defaultchoice)) ((string=? (symbol->string s)(string #\return)) (set! answer defaultchoice)) - ((string? (symbol->string s)) + ((and (symbol? s)(string? (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))) (procedure answer))) @@ -212,4 +214,5 @@ a valid CPAN URL now. cpan shell -- CPAN exploration and modules installation (v1.9402) -Enter 'h' for help.") \ No newline at end of file +Enter 'h' for help.") + diff --git a/scsh/SPAN/load.scm b/scsh/SPAN/load.scm index 6fb1e85..29ad5ce 100644 --- a/scsh/SPAN/load.scm +++ b/scsh/SPAN/load.scm @@ -26,6 +26,7 @@ ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF ;;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +(load "SPAN-util.scm") (load "SPAN.scm") (load "SPAN-client.scm") @@ -35,146 +36,136 @@ ;; h : display help ;; get : fetch file +(define answer "") + ;; question 1 (define SPAN-build-and-cache-dir (string-append (getenv "HOME") "/.span")) (define SPAN-download-target-dir (string-append (getenv "HOME") "/.span")) -;;prototype (define (SPAN-question~ droptext question answer defaultchoice) -(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-mirror-url "ask") -(define SPAN-download-target-dir (string-append SPAN-build-and-cache-dir "/" "sources") -(SPAN-question~ SPAN-shell-droptext-2 - "Download target directory" - "" - SPAN-download-target-dir - (lambda (answer) - (let ((dir (create-directory answer))) - (if (file-directory? answer) - (set! SPAN-download-target-dir answer) - #f)))) +(cond + ((and (file-exists? SPAN-build-and-cache-dir) + (file-exists? (string-append SPAN-build-and-cache-dir "/mirror"))) + (let ((SPAN-mirror-url (make-string-input-port + (open-input-file (string-append SPAN-build-and-cache-dir "/mirror"))))) + (SPAN-shell-spawn SPAN-mirror-url))) + (else + ;;prototype (define (SPAN-question~ droptext question answer defaultchoice) + (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-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) + (define SPAN-download-target-dir (string-append SPAN-build-and-cache-dir "/" "sources")) + (SPAN-question~ SPAN-shell-droptext-2 + "Download target directory" + "" + SPAN-download-target-dir + (lambda (answer) + (let ((dir (create-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) #f)))) -(define SPAN-config "no") -(SPAN-question~ SPAN-shell-droptext-4 - "Always commit changes to config variables to disk?" - "" - SPAN-config - (lambda (answer) - (set! SPAN-config answer) - #f)) + (define SPAN-config "no") + (SPAN-question~ SPAN-shell-droptext-4 + "Always commit changes to config variables to disk?" + "" + SPAN-config + (lambda (answer) + (set! SPAN-config answer) + #f)) -(define SPAN-build-Mb 100) -(SPAN-question~ SPAN-shell-droptext-5 - "Cache size for build directory (in MB)?" - "" - SPAN-build-Mb - (lambda (answer) - (set! SPAN-build-Mb answer) - #f)) + (define SPAN-build-Mb 100) + (SPAN-question~ SPAN-shell-droptext-5 + "Cache size for build directory (in MB)?" + "" + SPAN-build-Mb + (lambda (answer) + (set! SPAN-build-Mb answer) + #f)) -(define SPAN-expire 1) -(SPAN-question~ SPAN-shell-droptext-6 - "Let the index expire after how many days?" - "" - SPAN-expire - (lambda (answer) - (set! SPAN-expire answer) - #f)) + (define SPAN-expire 1) + (SPAN-question~ SPAN-shell-droptext-6 + "Let the index expire after how many days?" + "" + SPAN-expire + (lambda (answer) + (set! SPAN-expire answer) + #f)) -(define SPAN-scan-cache "atstart") -(SPAN-question~ SPAN-shell-droptext-7 - "Perform cache scanning (atstart or never)?" - "" - SPAN-scan-cache - (lambda (answer) - (set! SPAN-scan-cache answer) - #f)) + (define SPAN-scan-cache "atstart") + (SPAN-question~ SPAN-shell-droptext-7 + "Perform cache scanning (atstart or never)?" + "" + SPAN-scan-cache + (lambda (answer) + (set! SPAN-scan-cache answer) + #f)) -(define SPAN-cache-metadata "yes") -(SPAN-question~ SPAN-shell-droptext-8 - "Cache metadata (yes/no)?" - "" - SPAN-cache-metadata - (lambda (answer) - (set! SPAN-cache-metadata answer) - #f)) + (define SPAN-cache-metadata "yes") + (SPAN-question~ SPAN-shell-droptext-8 + "Cache metadata (yes/no)?" + "" + SPAN-cache-metadata + (lambda (answer) + (set! SPAN-cache-metadata answer) + #f)) -(define SPAN-policy-building "ask") -(SPAN-question~ SPAN-shell-droptext-9 - "Policy on building prerequisites (follow, ask or ignore)? [ask]" - "" - SPAN-policy-building - (lambda (answer) - (set! SPAN-policy-building answer) - #f)) + (define SPAN-policy-building "ask") + (SPAN-question~ SPAN-shell-droptext-9 + "Policy on building prerequisites (follow, ask or ignore)? [ask]" + "" + SPAN-policy-building + (lambda (answer) + (set! SPAN-policy-building answer) + #f)) -;; question 10 is under dev -;; question 11 is under dev -;; question 12 is under dev -;; question 13 is under dev + ;; question 10 is under dev + ;; question 11 is under dev + ;; question 12 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-21 - "Enter another URL or RETURN to quit: [] " - "" - SPAN-mirror-url-2 - (lambda (answer) - (set! SPAN-mirror-url-2 answer) - #f)) + (SPAN-question~ SPAN-shell-droptext-20 + "Please enter the URL of your CPAN mirror " + "" + SPAN-mirror-url + (lambda (answer) + (set! SPAN-mirror-url answer) + (let ((out (open-output-file (string-append SPAN-build-and-cache-dir "/mirror")))) + (write answer out)) + #f)) -(display SPAN-shell-droptext-22) -(define (url-bite-off url) - (let ((s "") - (do ((i 0 (+ i 1))) - ((>= i (string-length url)) - ;;(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 ""))))) + (define SPAN-mirror-url-2 "") + (SPAN-question~ SPAN-shell-droptext-21 + "Enter another URL or RETURN to quit: [] " + "" + SPAN-mirror-url-2 + (lambda (answer) + (set! SPAN-mirror-url-2 answer) + #f)) + + (display SPAN-shell-droptext-22) + (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.") \ No newline at end of file