From 8bed36a2d8ddb70481ae49338732c2aeccbebb5a Mon Sep 17 00:00:00 2001 From: erana Date: Wed, 18 Jan 2012 17:06:46 +0900 Subject: [PATCH] SPAN - questionaire refactoring --- scsh/SPAN/SPAN.scm | 136 +++++++++++++++++++++++++++++++++++++++++- scsh/SPAN/load.scm | 134 +---------------------------------------- scsh/SPAN/pkg-def.scm | 2 + 3 files changed, 138 insertions(+), 134 deletions(-) diff --git a/scsh/SPAN/SPAN.scm b/scsh/SPAN/SPAN.scm index 01af919..b08369f 100644 --- a/scsh/SPAN/SPAN.scm +++ b/scsh/SPAN/SPAN.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. +;; FXIME refactor (define (SPAN-question~ droptext question answer defaultchoice procedure) (let ((s "")) @@ -47,7 +48,7 @@ ((and (number? s)(string? (number->string s))) (set! answer (number->string s))) (else (SPAN-question~ droptext question answer defaultchoice))) - (procedure answer))) + procedure)) (define SPAN-shell-droptext-1 "The following questions are intended to help you with the @@ -216,3 +217,136 @@ a valid CPAN URL now. cpan shell -- CPAN exploration and modules installation (v1.9402) Enter 'h' for help.") + +(define questionaire + (lambda () + (define answer "") + (define SPAN-build-and-cache-dir (string-append (getenv "HOME") "/.span")) + (define SPAN-download-target-dir (string-append (getenv "HOME") "/.span")) + (define SPAN-mirror-url "localhost") + ;; question 1 + (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)))) 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)))) answer) + + (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)))) answer) + + (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)) answer) + + (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)) answer) + + (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)) answer) + + (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)) answer) + + (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)) answer) + + (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)) answer) + + ;; question 10 is under dev + ;; question 11 is under dev + ;; question 12 is under dev + ;; question 13 is under dev + + ;; ... until 20 + + + ((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)) answer) + + (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)) answer) + + (display SPAN-shell-droptext-22) + (SPAN-shell-spawn SPAN-mirror-url)) + ))) + diff --git a/scsh/SPAN/load.scm b/scsh/SPAN/load.scm index 29ad5ce..15e32ba 100644 --- a/scsh/SPAN/load.scm +++ b/scsh/SPAN/load.scm @@ -36,136 +36,4 @@ ;; 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")) -(define SPAN-mirror-url "ask") - -(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-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-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-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-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 - - ;; ... until 20 - - - (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)) - - (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)) - )) - +(questionaire) \ No newline at end of file diff --git a/scsh/SPAN/pkg-def.scm b/scsh/SPAN/pkg-def.scm index 5714841..d6addf5 100644 --- a/scsh/SPAN/pkg-def.scm +++ b/scsh/SPAN/pkg-def.scm @@ -11,6 +11,8 @@ (install-file "packages.scm" 'scheme) (install-file "SPAN-client.scm" 'scheme) (install-file "SPAN-server.scm" 'scheme) + (install-file "SPAN-server-daemon.scm" 'scheme) + (install-file "SPAN-server-daemon-record.scm" 'scheme) (install-file "SPAN-util.scm" 'scheme) (install-file "load.scm" 'scheme) (install-file "SPAN.scm" 'scheme))