1#lang racket/base 2(require racket/list 3 racket/match 4 racket/format 5 racket/function 6 racket/path 7 "../path.rkt" 8 "dirs.rkt" 9 "pkg-db.rkt" 10 "print.rkt") 11 12(provide pkg-show) 13 14(define (pkg-show indent only-pkgs 15 #:prefix-line [prefix-line #f] 16 #:directory? [dir? #f] 17 #:auto? [show-auto? #f] 18 #:full-checksum? [full-checksum #f] 19 #:long? [long? #t] 20 #:rx? [rx? #f] 21 #:name [name 'pkg-show]) 22 (when rx? 23 (when (not only-pkgs) 24 (pkg-error "regular-expression mode requires at least one pattern")) 25 (for ([str (in-list only-pkgs)]) 26 (regexp str (lambda (s) 27 (pkg-error (~a "bad regular-expression pattern;\n" 28 " " s "\n" 29 " in: " str)))))) 30 (define db (read-pkg-db)) 31 (define pkgs (sort (hash-keys db) string-ci<=?)) 32 (define auto-shown? #f) 33 (define to-show 34 (for/list ([pkg (in-list pkgs)] 35 #:unless (and only-pkgs 36 (not (memf (λ (v) (if rx? (regexp-match? v pkg) (equal? v pkg))) 37 only-pkgs))) 38 #:when (or show-auto? only-pkgs 39 (not (pkg-info-auto? (hash-ref db pkg))))) 40 (match-define (pkg-info orig-pkg checksum auto?) (hash-ref db pkg)) 41 (when auto? (set! auto-shown? #t)) 42 (append 43 (list (format "~a~a~a" 44 indent 45 pkg 46 (if auto? "*" "")) 47 (if (or checksum long?) 48 (format "~a" checksum) 49 "") 50 (let ([src (case (car orig-pkg) 51 [(link static-link clone) 52 (list* (car orig-pkg) 53 (path->string 54 (simple-form-path 55 (path->complete-path (cadr orig-pkg) 56 (pkg-installed-dir)))) 57 (cddr orig-pkg))] 58 [else orig-pkg])]) 59 (if long? 60 (~s src) 61 (apply ~a #:separator " " src)))) 62 (if dir? 63 (let ([p (path->string 64 (simple-form-path 65 (pkg-directory* pkg #:db db)))]) 66 (list (if long? 67 (~s p) 68 (~a p)))) 69 empty)))) 70 (when prefix-line 71 (printf "~a\n" prefix-line)) 72 (if (null? to-show) 73 (printf " [none]\n") 74 (let* ([col-headers (list* (format "~aPackage~a" 75 indent 76 (if auto-shown? "[*=auto]" "")) 77 "Checksum" 78 "Source" 79 (if dir? '("Directory") '()))] 80 [checksum-index (for/first ([hdr (in-list col-headers)] 81 [i (in-naturals)] 82 #:when (string=? hdr "Checksum")) i)] 83 [exact-columns (if (and full-checksum checksum-index) 84 (list checksum-index) 85 '())]) 86 (table-display 87 #:exact-columns exact-columns 88 long? 89 (list* 'right 'right 'middle 90 (if dir? '(left) '())) 91 (list* col-headers to-show)))) 92 (unless (or only-pkgs show-auto?) 93 (define n (for/sum ([pkg (in-list pkgs)] 94 #:when (pkg-info-auto? (hash-ref db pkg))) 95 1)) 96 (unless (zero? n) 97 (printf "~a[~a auto-installed package~a not shown]\n" 98 indent 99 n 100 (if (= n 1) "" "s"))))) 101 102(define (table-display long? dots-poses l #:exact-columns [exact-columns '()]) 103 (define how-many-cols (length (first l))) 104 (define full-max-widths 105 (for/list ([col (in-range how-many-cols)]) 106 (apply max (map (compose string-length (curryr list-ref col)) l)))) 107 (define sep (if long? 4 2)) 108 (define COLUMNS (or (cond 109 [long? 80] 110 [(getenv "COLUMNS") 111 => (lambda (s) 112 (define v (string->number s)) 113 (and (exact-positive-integer? v) v))] 114 [else #f]) 115 80)) 116 (define max-widths 117 (cond 118 [(or long? 119 ((apply + full-max-widths) . < . (- COLUMNS (* sep (sub1 how-many-cols))))) 120 full-max-widths] 121 [else 122 (define avail (- COLUMNS 123 (car full-max-widths) 124 (* sep (sub1 how-many-cols)))) 125 (cons (car full-max-widths) 126 (for/list ([(c i) (in-indexed (in-list (cdr full-max-widths)))]) 127 (if (memq (+ i 1) exact-columns) 128 c 129 (let ([frac 130 ;; Give last column twice the space: 131 (if (= i (sub1 how-many-cols)) 132 (/ 2 how-many-cols) 133 (/ 1 how-many-cols))]) 134 (max 3 135 (floor (* avail frac)))))))])) 136 (for ([row (in-list l)]) 137 (for ([col (in-list row)] 138 [i (in-naturals 1)] 139 [width (in-list max-widths)] 140 [dots-pos (in-list dots-poses)]) 141 (define col-width (string-length col)) 142 (printf "~a~a" 143 (if (or (col-width . <= . width) 144 (memq (- i 1) exact-columns)) 145 col 146 (case dots-pos 147 [(right) 148 ;; Checksum: show prefix: 149 (~a (substring col 0 (- width 3)) 150 "...")] 151 [(middle) 152 ;; Source 153 ;; To start "..." at a space: 154 (define m (regexp-match-positions #rx" " col)) 155 (define left 156 (cond 157 [(and m 158 ((caar m) . < . (- width 3))) 159 ;; Dots at space: 160 (caar m)] 161 [else 162 ;; Put dots in middle: 163 (quotient (- width 3) 2)])) 164 (~a (substring col 0 left) 165 "..." 166 (substring col (+ (- col-width width) 167 3 left)))] 168 [(left) 169 ;; Put dots at start: 170 (~a "..." 171 (substring col (min col-width (- col-width width -3))))])) 172 (if (= i how-many-cols) 173 "" 174 (let ([len (min (string-length col) 175 width)]) 176 (make-string (+ (- width len) sep) #\space))))) 177 (printf "\n"))) 178