📄 chicken-setup.scm
字号:
(not (not (alist-ref 'documentation (read) eq?))) ) ) ) ) )(define (delete-undocumented-extensions rpath lst) (filter (cut extension-documented? rpath <>) lst) )(define (build-doc-index) (let ((rpath (repository-path)) (hn (get-host-name))) (with-output-to-file (doc-stylesheet #t) (lambda () (display #<<EOFbody, html { color: #000; background-color: #fff; font: 9pt "Lucida Grande", "Verdana", sans-serif; line-height: 1.6; margin: 0; padding: 0;}a { color: #669; text-decoration: none;}a:visited { color: #555; }a:active { color: #966; }a:hover { color: #bbd; }#title { border-bottom: 1px solid #669; background-color: #669; margin: 0; padding: 0 3em 0.2em; float: left; color: #fff;}#install-info { clear: left; padding: 1em;}#official-index { padding: 1em; float: right;}#egg-index { width: 60%; margin: auto; border-spacing: 0;}/* Everything but the first one is aligned right */#egg-index tr > * { text-align: left;}#egg-index tr > * + * { text-align: right;}#egg-index a { display: block;}thead tr { color: #fff; background-color: #669;}th { padding: 0.1em 1em 0.3em;}td { padding: 0.3em 1em;}tr.even { background-color: #eee;}tr { background-color: white;}EOF ))) (with-output-to-file (doc-index #t) (lambda () (print "<html><head><title>Egg documentation index for " hn "</title><link rel=\"stylesheet\" type=\"text/css\" href=\"style.css\"/></head>") (print "<body><a id=\"official-index\" href=\"http://www.call-with-current-continuation.org/" *default-eggdir* "/index.html\">Visit the official egg index</a>") (print "<h1 id=\"title\">Egg documentation index:</h1>") (printf "<p id=\"install-info\">CHICKEN: ~a<br>Host: ~a<br>Repository path: ~a<br><p>~%" (chicken-version #t) (get-host-name) rpath) (print "<table id=\"egg-index\">") (print "<thead><tr><th>Egg name</th><th>Version</th><th>Release</th></tr></thead>\n<tbody>") (let ((c 0)) (for-each (lambda (f) (and-let* ((info (extension-information f))) (printf "<tr~a><td>" (if (even? c) " class=\"even\"" "")) (set! c (add1 c)) (let ((doc (assq 'documentation info))) (if doc (printf "<a href=\"~a\">~a</a>" (cadr doc) f) (display f) ) (printf "</td>~%") (printf "<td>~A</td>" (car (alist-ref 'version info eq? '("")))) (printf "<td>~A</td>" (car (alist-ref 'release info eq? '("")))) (printf "</tr>~%") ) ) ) (delete-undocumented-extensions rpath (sort (delete-duplicates (grep "^[^.].*\\.*$" (map pathname-file (directory rpath))) string=?) string<?) ) ) (display "</tbody></table></body></font></html>\n") ) ) ) ) );;; Output stuff(define (format-string str cols #!optional right (padc #\space)) (let* ((len (string-length str)) (pad (make-string (fxmax 0 (fx- cols len)) padc)) ) (if right (string-append pad str) (string-append str pad) ) ) )(define get-terminal-width (let ((default-width 78)) ; Standard default terminal width (lambda () (let ((cop (current-output-port))) (if (terminal-port? cop) (with-exception-handler (lambda (_) default-width) (lambda () (call-with-values (lambda () (terminal-size cop)) (lambda (_ cols) cols)))) default-width)))))(define (list-installed) (let* ((line-width (get-terminal-width)) (eggs (sort (delete-duplicates (grep "^[^.].*\\.*$" (map pathname-file (directory (repository-path)))) string=?) string<?)) (version-number-width (fold (lambda (egg maxlen) (max maxlen (or (and-let* ((info (extension-information egg)) (v (assq 'version info))) (string-length (->string (cadr v)))) 0))) 0 eggs)) (version-width (fx+ version-number-width 9)) (release-width 22) (name-width (fxmax (- line-width version-width release-width 3) 12))) (for-each (lambda (f) (and-let* ((info (extension-information f))) (print (format-string (->string f) name-width) " " (format-string (or (and-let* ((v (assq 'version info))) (sprintf "Version: ~A" (format-string (->string (cadr v)) version-number-width #t))) "") version-width #t) " " (or (and-let* ((r (assq 'release info))) (sprintf "(Release ~a)" (cadr r)) ) "") ) ) ) eggs)));;; Command line processing(define (main args) (define (parse-host host eggdir) (set! *repository-hosts* (cons (match (string-match "(.+)\\:([0-9]+)" host) ((_ host port) (list host (if eggdir *default-eggdir* "") (string->number port))) (_ (list host (if eggdir (conc *default-eggdir* "") 80)) ) ) *repository-hosts*) ) ) (setup-root-directory *base-directory*) (let ((uinst #f) (anydone #f)) (let loop ((args args)) (match args (((or "-help" "--help") . _) (usage)) (("-uninstall" . more) (set! uinst #t) (loop more) ) (("-list" more ...) (if (pair? more) (for-each (lambda (e) (let ((info (extension-information e))) (cond (info (print e ":\n") (pp info) (newline) ) (else (print "Warning: No extension named `" e "' installed.\n")) ) ) ) more) (list-installed) ) (exit) ) (("-run" fname . more) (load fname) (loop more) ) (("-repository") (print (repository-path)) (exit) ) (("-repository" dir . more) (repository-path dir) (loop more) ) (("-tree" file . more) (set! *repository-tree* (with-input-from-file file read)) (loop more) ) (("--" . more) (exit) ) (("-program-path") (print (program-path)) (exit) ) (("-install-prefix" path . more) (installation-prefix path) (loop more) ) (("-build-prefix" path . more) (setup-build-prefix path) (loop more) ) (("-download-path" path . more) (setup-download-directory path) (loop more) ) (("-program-path" dir . more) (program-path dir) (loop more) ) (("-version" . _) (printf "chicken-setup - ~A~%" (chicken-version #t)) (exit) ) (("-release" . _) (print (chicken-version)) (exit) ) (("-script" filename . args) (command-line-arguments args) (load filename) (exit) ) (("-eval" expr . more) (eval `(begin ,@(with-input-from-string expr read-file))) (set! anydone #t) (loop more) ) (("-fetch" . more) (set! *fetch-only* #t) (set! *keep-stuff* #t) (loop more) ) (("-host" host . more) (match (string-match "http://(.*)" host) ((_ host) (parse-host host #t) ) (_ (parse-host host #t)) ) (loop more) ) (("-proxy" proxy . more) (match (string-match "(.+)\\:([0-9]+)" proxy) ((_ proxy port) (set! *proxy-host* proxy) (set! *proxy-port* (string->number port))) (_ (set! *proxy-host* proxy) (set! *proxy-port* 80)) ) (loop more) ) (("-keep" . more) (set! *keep-stuff* #t) (set! *csc-options* (append *csc-options* (list "-k"))) (loop more) ) (("-verbose" . more) (setup-verbose-flag #t) (set! *csc-options* (append *csc-options* (list "-v"))) (loop more) ) (("-csc-option" opt . more) (set! *csc-options* (append *csc-options* (list opt))) (loop more) ) (("-ls" ext . more) (and-let* ((info (extension-information ext)) (files (assq 'files info)) ) (for-each print (cdr files) ) ) (exit) ) (("-dont-ask" . more) (set! *dont-ask* #t) (loop more) ) (("-no-install" . more) (setup-install-flag #f) (set! *keep-stuff* #t) (loop more) ) (("-docindex" . more) (let ((di (doc-index #t))) (unless (file-exists? di) (build-doc-index) ) (print di) ) ) (("-debug" . more) (set! *debug* #t) (loop more) ) (("-revision" rev . more) (set! *revision* rev) (loop more) ) (("-svn" url . more) (set! *svn-repository* url) (set! *dont-ask* #t) (loop more) ) (("-svn-trunk" url . more) (set! *svn-trunk* url) (set! *dont-ask* #t) (loop more) ) (("-test" . more) (set! *run-tests* #t) (loop more) ) (("-local" path . more) (set! *local-repository* path) (set! *dont-ask* #t) (loop more) ) (("-create-tree" dir . more) (create-repository-file dir) (set! anydone #t) (loop more) ) (("-fetch-tree" . more) (set! *fetch-tree-only* #t) (set! anydone #t) (loop more) ) (("-host-extension" . more) (host-extension #t) (loop more) ) (((or "-run" "-script" "-proxy" "-host" "-csc-option" "-ls" "-install-prefix" "-tree" "-local" "-svn" "-svn-trunk" "-eval" "-create-tree" "-build-prefix" "-download-path")) (error "missing option argument" (car args)) ) ((filename . more) (cond ((and (> (string-length filename) 0) (char=? #\- (string-ref filename 0))) (let ((os (string->list (substring filename 1)))) (if (every (cut memq <> short-options) os) (loop (append (map (lambda (s) (list-ref long-options (list-index (cut eq? <> s) short-options))) os) more) ) (error "invalid option" filename) ) ) ) (else (set! anydone #t) ((if uinst uninstall-extension install) (match (string-match "http://([^/]+)/(.+)" filename) ((_ host path) (parse-host host #f) (set! *dont-ask* #t) (conc "/" path) ) (_ filename)) ) (loop more) ) ) ) (() (unless anydone (let ((setups (glob "*.setup"))) (if (null? setups) (printf "No setup scripts to process~%") (for-each (if uinst uninstall-extension install) setups) ) ) ) (when *fetch-tree-only* (download-repository-tree) (pp *repository-tree*) ) (when *rebuild-doc-index* (when (setup-verbose-flag) (printf "Rebuilding documentation index...\n")) (build-doc-index) ) (unless *keep-stuff* (for-each (lambda (f) (run (,*remove-command* ,(quotewrap f))) ) *fetched-eggs*)) #f) ) ) ) )(handle-exceptions ex (begin (print-error-message ex) (exit -1) ) (call/cc (lambda (return) (set! *abort-hook* return) (main (append (string-split (or (getenv "CHICKEN_SETUP_OPTIONS") "")) (command-line-arguments) ) ) ) ) (clear-builddir) )⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -