~ chicken-core (chicken-5) /chicken-status.scm
Trap1;;;; chicken-status.scm2;3; Copyright (c) 2008-2022, The CHICKEN Team4; All rights reserved.5;6; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following7; conditions are met:8;9; Redistributions of source code must retain the above copyright notice, this list of conditions and the following10; disclaimer.11; Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following12; disclaimer in the documentation and/or other materials provided with the distribution.13; Neither the name of the author nor the names of its contributors may be used to endorse or promote14; products derived from this software without specific prior written permission.15;16; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS17; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY18; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR19; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR20; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR21; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY22; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR23; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE24; POSSIBILITY OF SUCH DAMAGE.2526(module main ()2728 (import (scheme)29 (chicken base)30 (chicken condition)31 (chicken file)32 (chicken fixnum)33 (chicken foreign)34 (chicken format)35 (chicken irregex)36 (chicken port)37 (chicken pathname)38 (chicken platform)39 (chicken pretty-print)40 (chicken process-context)41 (chicken sort)42 (only (chicken string) ->string))4344 (include "mini-srfi-1.scm")45 (include "egg-environment.scm")46 (include "egg-information.scm")4748 (define host-extensions #t)49 (define target-extensions #t)5051 (define get-terminal-width52 (let ((default-width 79)) ; Standard default terminal width53 (lambda ()54 (let ((cop (current-output-port)))55 (if (terminal-port? cop)56 (let ((w (handle-exceptions exn 0 (nth-value 1 (terminal-size cop)))))57 (if (zero? w)58 default-width59 (min default-width w)))60 default-width)))))6162 (define list-width (quotient (- (get-terminal-width) 2) 2))6364 (define (repo-path)65 (if (and cross-chicken (not host-extensions))66 (##sys#split-path (destination-repository 'target))67 (repository-path)))6869 (define (grep rx lst)70 (filter (cut irregex-search rx <>) lst))7172 (define (read-info egg #!optional (dir (repo-path)) (ext +egg-info-extension+))73 (let ((f (chicken.load#find-file (make-pathname #f egg ext) dir)))74 (and f (load-egg-info f))))7576 (define (filter-egg-names eggs patterns mtch)77 (let* ((names (cond ((null? patterns) eggs)78 (mtch79 (concatenate80 (map (lambda (pat)81 (grep (irregex (glob->sre pat)) eggs))82 patterns)))83 (else84 (filter85 (lambda (egg)86 (any (cut string=? <> egg) patterns))87 eggs)))))88 (delete-duplicates names string=?)))8990 (define (gather-eggs)91 (delete-duplicates92 (append-map93 (lambda (dir)94 (map pathname-file95 (glob (make-pathname dir "*" +egg-info-extension+))))96 (repo-path))97 equal?))9899 (define (format-string str cols #!optional right (padc #\space))100 (let* ((len (string-length str))101 (pad (make-string (fxmax 0 (fx- cols len)) padc)) )102 (if right103 (string-append pad str)104 (string-append str pad) ) ) )105106 (define (list-installed-eggs eggs #!optional (dir (repo-path))107 (ext +egg-info-extension+))108 (for-each (cut list-egg-info <> dir ext)109 (sort eggs string<?)))110111 (define (list-egg-info egg dir ext)112 (let ((version113 (or (let ((info (read-info egg dir ext)))114 (and info (get-egg-property info 'version)))115 (let ((file (file-exists?116 (make-pathname (list cache-metadata-directory egg)117 +version-file+))))118 (and file (with-input-from-file file read)))119 "unknown")))120 (print (format-string (string-append egg " ")121 list-width #f #\.)122 (format-string (string-append " version: "123 (->string version))124 list-width #t #\.))))125126 (define (list-cached-eggs pats mtch)127 (when (directory-exists? cache-directory)128 (for-each129 (lambda (egg)130 (list-egg-info egg (make-pathname cache-directory egg) +egg-extension+))131 (sort (filter-egg-names (directory cache-directory) pats mtch) string<?))))132133 (define (gather-components lst mode)134 (append-map (cut gather-components-rec <> mode) lst))135136 (define (gather-components-rec info mode)137 (case (car info)138 ((host)139 (if host-extensions (gather-components (cdr info) 'host) '()))140 ((target)141 (if target-extensions (gather-components (cdr info) 'target) '()))142 ((extension) (list (list 'extension mode (cadr info))))143 ((data) (list (list 'data mode (cadr info))))144 ((generated-source-file) (list (list 'generated-source-file mode (cadr info))))145 ((c-include) (list (list 'c-include mode (cadr info))))146 ((scheme-include) (list (list 'scheme-include mode (cadr info))))147 ((program) (list (list 'program mode (cadr info))))148 ((c-object) (list (list 'c-object mode (cadr info))))149 (else '())))150151 (define (list-installed-components eggs)152 (let ((w (quotient (- (get-terminal-width) 2) 2)))153 (for-each154 (lambda (egg)155 (let* ((info (read-info egg))156 (version (get-egg-property info 'version))157 (comps (get-egg-property* info 'components)))158 (if version159 (print (format-string (string-append egg " ") w #f #\.)160 (format-string (string-append " version: "161 (->string version))162 w #t #\.))163 (print egg))164 (when comps165 (let ((lst (gather-components comps #f)))166 (for-each167 (lambda (comp)168 (print " " (format-string (->string (car comp)) 32)169 " " (format-string (->string (caddr comp)) 32)170 (case (cadr comp)171 ((host) " (host)")172 ((target) " (target)")173 (else ""))))174 lst)))))175 eggs)))176177 (define (list-installed-files eggs)178 (for-each179 print180 (sort181 (append-map182 (lambda (egg)183 (get-egg-property* (read-info egg) 'installed-files))184 eggs)185 string<?)))186187 (define (dump-installed-versions eggs)188 (for-each189 (lambda (egg)190 (let ((version (get-egg-property (read-info egg) 'version)))191 (pp (cons (string->symbol egg)192 (if version (list version) '())))))193 eggs))194195 (define (usage code)196 (print #<<EOF197usage: chicken-status [OPTION ...] [NAME ...]198199 -h -help show this message200 -version show version and exit201 -c -components list installed components202 -cached list eggs in cache203 -f -files list installed files204 -list dump installed extensions and their versions in "override" format205 -match treat NAME as glob pattern206 -host when cross-compiling, only show host extensions207 -target when cross-compiling, only show target extensions208EOF209);|210 (exit code))211212 (define short-options '(#\h #\f #\c #\a))213214 (define (main args)215 (let ((files #f)216 (comps #f)217 (dump #f)218 (cached #f)219 (mtch #f))220 (let loop ((args args) (pats '()))221 (if (null? args)222 (cond ((and comps (or dump files))223 (with-output-to-port (current-error-port)224 (cut print "-components cannot be used with -list."))225 (exit 1))226 (cached (list-cached-eggs pats mtch))227 (else228 ((cond (dump dump-installed-versions)229 (files list-installed-files)230 (comps list-installed-components)231 (else list-installed-eggs))232 (filter-egg-names (gather-eggs) pats mtch))))233 (let ((arg (car args)))234 (cond ((member arg '("-help" "-h" "--help"))235 (usage 0))236 ((string=? arg "-host")237 (set! target-extensions #f)238 (loop (cdr args) pats))239 ((string=? arg "-target")240 (set! host-extensions #f)241 (loop (cdr args) pats))242 ((string=? arg "-match")243 (set! mtch #t)244 (loop (cdr args) pats))245 ((string=? arg "-cached")246 (set! cached #t)247 (loop (cdr args) pats))248 ((string=? arg "-list")249 (set! dump #t)250 (loop (cdr args) pats))251 ((or (string=? arg "-f") (string=? arg "-files"))252 (set! files #t)253 (loop (cdr args) pats))254 ((or (string=? arg "-c") (string=? arg "-components"))255 (set! comps #t)256 (loop (cdr args) pats))257 ((string=? arg "-version")258 (print (chicken-version))259 (exit 0))260 ((and (positive? (string-length arg))261 (char=? #\- (string-ref arg 0)))262 (if (> (string-length arg) 2)263 (let ((sos (string->list (substring arg 1))))264 (if (every (cut memq <> short-options) sos)265 (loop (append (map (cut string #\- <>) sos)266 (cdr args)) pats)267 (usage 1)))268 (usage 1)))269 (else (loop (cdr args) (cons arg pats)))))))))270271 (main (command-line-arguments))272273 )