~ chicken-core (master) /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 ((installed-c-object) (list (list 'installed-c-object mode (cadr info))))150 (else '())))151152 (define (list-installed-components eggs)153 (let ((w (quotient (- (get-terminal-width) 2) 2)))154 (for-each155 (lambda (egg)156 (let* ((info (read-info egg))157 (version (get-egg-property info 'version))158 (comps (get-egg-property* info 'components)))159 (if version160 (print (format-string (string-append egg " ") w #f #\.)161 (format-string (string-append " version: "162 (->string version))163 w #t #\.))164 (print egg))165 (when comps166 (let ((lst (gather-components comps #f)))167 (for-each168 (lambda (comp)169 (print " " (format-string (->string (car comp)) 32)170 " " (format-string (->string (caddr comp)) 32)171 (case (cadr comp)172 ((host) " (host)")173 ((target) " (target)")174 (else ""))))175 lst)))))176 eggs)))177178 (define (list-installed-files eggs)179 (for-each180 print181 (sort182 (append-map183 (lambda (egg)184 (get-egg-property* (read-info egg) 'installed-files))185 eggs)186 string<?)))187188 (define (dump-installed-versions eggs)189 (for-each190 (lambda (egg)191 (let ((version (get-egg-property (read-info egg) 'version)))192 (pp (cons (string->symbol egg)193 (if version (list version) '())))))194 eggs))195196 (define (usage code)197 (print #<<EOF198usage: chicken-status [OPTION ...] [NAME ...]199200 -h -help show this message201 -version show version and exit202 -c -components list installed components203 -cached list eggs in cache204 -f -files list installed files205 -list dump installed extensions and their versions in "override" format206 -match treat NAME as glob pattern207 -host when cross-compiling, only show host extensions208 -target when cross-compiling, only show target extensions209EOF210);|211 (exit code))212213 (define short-options '(#\h #\f #\c #\a))214215 (define (main args)216 (let ((files #f)217 (comps #f)218 (dump #f)219 (cached #f)220 (mtch #f))221 (let loop ((args args) (pats '()))222 (if (null? args)223 (cond ((and comps (or dump files))224 (with-output-to-port (current-error-port)225 (cut print "-components cannot be used with -list."))226 (exit 1))227 (cached (list-cached-eggs pats mtch))228 (else229 ((cond (dump dump-installed-versions)230 (files list-installed-files)231 (comps list-installed-components)232 (else list-installed-eggs))233 (filter-egg-names (gather-eggs) pats mtch))))234 (let ((arg (car args)))235 (cond ((member arg '("-help" "-h" "--help"))236 (usage 0))237 ((string=? arg "-host")238 (set! target-extensions #f)239 (loop (cdr args) pats))240 ((string=? arg "-target")241 (set! host-extensions #f)242 (loop (cdr args) pats))243 ((string=? arg "-match")244 (set! mtch #t)245 (loop (cdr args) pats))246 ((string=? arg "-cached")247 (set! cached #t)248 (loop (cdr args) pats))249 ((string=? arg "-list")250 (set! dump #t)251 (loop (cdr args) pats))252 ((or (string=? arg "-f") (string=? arg "-files"))253 (set! files #t)254 (loop (cdr args) pats))255 ((or (string=? arg "-c") (string=? arg "-components"))256 (set! comps #t)257 (loop (cdr args) pats))258 ((string=? arg "-version")259 (print (chicken-version))260 (exit 0))261 ((and (positive? (string-length arg))262 (char=? #\- (string-ref arg 0)))263 (if (> (string-length arg) 2)264 (let ((sos (string->list (substring arg 1))))265 (if (every (cut memq <> short-options) sos)266 (loop (append (map (cut string #\- <>) sos)267 (cdr args)) pats)268 (usage 1)))269 (usage 1)))270 (else (loop (cdr args) (cons arg pats)))))))))271272 (main (command-line-arguments))273274 )