From 243332f4297521bd3c84e9eb77ab2b9492dac9aa Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 16 Nov 2011 10:29:15 -0700 Subject: [PATCH] move .ico support from `raco exe' internals to `file/ico' --- collects/compiler/embed-unit.rkt | 4 +- collects/compiler/private/winicon.rkt | 858 -------------------------- collects/file/ico.rkt | 806 ++++++++++++++++++++++++ collects/file/scribblings/file.scrbl | 1 + collects/file/scribblings/ico.scrbl | 79 +++ 5 files changed, 888 insertions(+), 860 deletions(-) delete mode 100644 collects/compiler/private/winicon.rkt create mode 100644 collects/file/ico.rkt create mode 100644 collects/file/scribblings/ico.scrbl diff --git a/collects/compiler/embed-unit.rkt b/collects/compiler/embed-unit.rkt index 3f8cf7c972..eb4d7952d1 100644 --- a/collects/compiler/embed-unit.rkt +++ b/collects/compiler/embed-unit.rkt @@ -10,7 +10,7 @@ setup/dirs setup/variant "embed-sig.rkt" - "private/winicon.rkt" + file/ico "private/winsubsys.rkt" "private/macfw.rkt" "private/mach-o.rkt" @@ -1371,7 +1371,7 @@ (let ([m (and (eq? 'windows (system-type)) (assq 'ico aux))]) (when m - (install-icon dest-exe (cdr m)))) + (replace-icos (read-icos (cdr m)) dest-exe))) (let ([m (and (eq? 'windows (system-type)) (assq 'subsystem aux))]) (when m diff --git a/collects/compiler/private/winicon.rkt b/collects/compiler/private/winicon.rkt deleted file mode 100644 index 717844298b..0000000000 --- a/collects/compiler/private/winicon.rkt +++ /dev/null @@ -1,858 +0,0 @@ - -(module winicon mzscheme - (require mzlib/list) - (provide install-icon - extract-icons - parse-icon - build-icon) - - (define (byte->integer p) - (read-byte p)) - (define (word->integer p) - (integer-bytes->integer (read-bytes 2 p) #f #f)) - (define (dword->integer p) - (integer-bytes->integer (read-bytes 4 p) #f #f)) - - ;; The 0 added in the alpha position apparently means "ignore the alpha - ;; and use the mask, instead" - (define (3/2word->integer p) - (integer-bytes->integer (bytes-append (read-bytes 3 p) #"\0") #f #f)) - - (define (integer->word i p) - (display (integer->integer-bytes i 2 #f #f) p)) - (define (integer->dword i p) - (display (integer->integer-bytes i 4 #f #f) p)) - - (define (flag v) - (positive? (bitwise-and #x80000000 v))) - (define (value v) - (bitwise-and #x7FFFFFFF v)) - - (define (skip-to-image-headers-after-signature p) - ;; p is expected to be a file port - (file-position p 60) - (let ([pos (word->integer p)]) - ;; pos points to IMAGE_NT_HEADERS - (file-position p pos) - (unless (= #x4550 (dword->integer p)) - (error "bad signature")) - pos)) - - (define (get-image-base p) - (let ([pos (skip-to-image-headers-after-signature p)]) - (file-position p (+ 4 - 20 - 28)) - (dword->integer p))) - - (define (find-section p find-name) - (let ([pos (skip-to-image-headers-after-signature p)]) - (word->integer p) ; skip machine - (let ([num-sections (word->integer p)] - [_ (begin (dword->integer p) - (dword->integer p) - (dword->integer p))] - [size (word->integer p)]) - (let ([pos (+ pos - 4 ; Signature : DWORD - 20 ; FileHeader: IMAGE_FILE_HEADER - size)]) ; "optional" header - (let sloop ([section 0][section-pos pos]) - (if (= section num-sections) - (error 'find-section "can't find section: ~e" find-name) - (begin - (file-position p section-pos) - ;; p points to an IMAGE_SECTION_HEADER - (let ([name (read-bytes 8 p)]) - (if (bytes=? find-name name) - (let ([_ (dword->integer p)]) ; skip - (values (dword->integer p) ; virtual address - (dword->integer p) ; length - (dword->integer p))); file pos - (sloop (add1 section) (+ section-pos 40))))))))))) - - (define (find-rsrc-start p re:rsrc) - (let-values ([(rsrc-virtual-addr rsrc-len rsrc-pos) - (find-section p #".rsrc\0\0\0")]) - (let loop ([dir-pos 0][path ""]) - (file-position p (+ rsrc-pos dir-pos 12)) - (let ([num-named (word->integer p)] - [num-ided (word->integer p)]) - (let iloop ([i 0]) - (if (= i (+ num-ided num-named)) - #f - (let ([name-delta (dword->integer p)] - [data-delta (dword->integer p)] - [next (file-position p)]) - (or (let ([name (if (flag name-delta) - (begin - (file-position p (+ rsrc-pos (value name-delta))) - (let* ([len (word->integer p)]) - ;; len is in unicode chars... - (let ([unistr (read-bytes (* 2 len) p)]) - ;; Assume it fits into ASCII... - (regexp-replace* "\0" - (bytes->string/latin-1 unistr) - "")))) - (value name-delta))]) - ;;(printf "Name: ~a~a = ~a\n" path name (+ rsrc-pos (value data-delta))) - (let ([full-name (format "~a~a" path name)]) - (if (flag data-delta) - (loop (value data-delta) (string-append full-name ".")) - ;; Found the icon? - (and (regexp-match re:rsrc full-name) - ;; Yes, so read IMAGE_RESOURCE_DATA_ENTRY - (begin - (file-position p (+ rsrc-pos (value data-delta))) - (cons - (+ (dword->integer p) ; offset (an RVA) - (- rsrc-pos - rsrc-virtual-addr)) - (dword->integer p))))))) ; size - (begin - (file-position p next) - (iloop (add1 i))))))))))) - - ;; >>> Probably doesn't work <<< - (define (find-import-names p) - (let-values ([(seg-virtual-addr seg-len seg-pos) - (find-section p #".idata\0\0")]) - (let loop ([pos seg-pos]) - ;; pos points to an IMAGE_IMPORT_DESCRIPTOR; - ;; skip first 4 fields - (file-position p pos) - (if (zero? (dword->integer p)) ; 0 is terminator - null - (begin - (dword->integer p) - (dword->integer p) - ;; next field is name - (let ([name-pos (+ (dword->integer p) ; RVA to nul-terminated name - (- seg-pos seg-virtual-addr))]) - (file-position p name-pos) - (let ([name (regexp-match "^[^\0]*" p)]) - (cons (cons (car name) name-pos) - (loop (+ pos 20)))))))))) - - ;; >>> Doesn't work <<< - (define (find-delay-loads p) - (let-values ([(seg-virtual-addr seg-len seg-pos) - (find-section p #".text\0\0")]) - (let ([pos (skip-to-image-headers-after-signature p)] - [image-base (get-image-base p)]) - (let ([pos (+ pos - 4 ; Signature : DWORD - 20 ; FileHeader: IMAGE_FILE_HEADER - 96 ; IMAGE_OPTIONAL_HEADER up to directory - 104)] ; skip 13 directory entries - [vdelta image-base]) - (file-position p pos) - (let loop ([delay-pos (dword->integer p)]) - (printf "~a ~a\n" delay-pos vdelta) - (file-position p (+ delay-pos vdelta)) - (dword->integer p) ; skip attributes - (let ([name-pos (dword->integer p)]) - (printf "~a ~a\n" name-pos vdelta) - (file-position p (+ name-pos vdelta)) - (let ([name (regexp-match "^[^\0]*" p)]) - (printf "~a\n" name)))))))) - - (define-struct icon (desc data)) - ;; desc is (list width height colors 0 planes bitcount) - ;; data is (cons pos string) - - (define (num-colors l) - (let ([n (caddr l)]) - (if (zero? n) - (arithmetic-shift 1 (list-ref l 5)) - n))) - - (define (install-icon exe-file ico-file . extra-icons) - (let ([ico-icons (append (if ico-file - (extract-icons ico-file) - null) - extra-icons)] - [exe-icons (extract-icons exe-file)]) - (let ([p (open-output-file exe-file 'update)]) - (dynamic-wind - void - (lambda () - (for-each (lambda (exe-icon) - (let ([best-ico-icon - ;; Find exact match? - (ormap (lambda (ico-icon) - (let ([le (icon-desc exe-icon)] - [li (icon-desc ico-icon)]) - (and (= (car li) (car le)) - (= (cadr li) (cadr le)) - (= (num-colors li) (num-colors le)) - (= (bytes-length (cdr (icon-data exe-icon))) - (bytes-length (cdr (icon-data ico-icon)))) - ico-icon))) - ico-icons)]) - (let ([ico-icon (or best-ico-icon - ;; Look for a conversion, if we - ;; need a 16x16, 32x32, or 48x48 - ;; icon - (and - (= (car (icon-desc exe-icon)) - (cadr (icon-desc exe-icon))) - (memq (car (icon-desc exe-icon)) - '(16 32 48)) - (let ([biggest-colorest #f]) - (for-each - (lambda (ico-icon) - (let ([w (car (icon-desc ico-icon))] - [exew (car (icon-desc exe-icon))]) - (when (and - (= w - (cadr (icon-desc ico-icon))) - (memq w '(16 32 48)) - (or - (not biggest-colorest) - (and (= w exew) - (not (= exew (car (icon-desc biggest-colorest))))) - (and (= w exew) - (> (num-colors (icon-desc ico-icon)) - (num-colors (icon-desc biggest-colorest)))) - (and (not (= exew (car (icon-desc biggest-colorest)))) - (or (> w (car (icon-desc biggest-colorest))) - (> (num-colors (icon-desc ico-icon)) - (num-colors (icon-desc biggest-colorest))))))) - (set! biggest-colorest ico-icon)))) - ico-icons) - (and - biggest-colorest - ;; Convert... - (let* ([src-size (car (icon-desc biggest-colorest))] - [dest-size (car (icon-desc exe-icon))] - [src (parse-icon biggest-colorest)] - [image (list-ref src 3)] - [mask (list-ref src 4)] - [has-alpha? (<= 256 (num-colors (icon-desc biggest-colorest)))]) - (if (= src-size dest-size) - (build-icon exe-icon - (if has-alpha? - image - (mask->alpha image mask)) - mask) - (let ([cvt - (cond - [(and (= src-size 32) (= dest-size 16)) - (lambda (i) (48->16 (32->48 i)))] - [(and (= src-size 32) (= dest-size 48)) - 32->48] - [(and (= src-size 48) (= dest-size 16)) - 48->16] - [(and (= src-size 48) (= dest-size 32)) - 48->32] - [(and (= src-size 16) (= dest-size 32)) - 16->32] - [(and (= src-size 16) (= dest-size 48)) - (lambda (i) (32->48 (16->32 i)))])]) - (let ([mask (cvt mask)]) - (build-icon exe-icon - (if has-alpha? - image - (mask->alpha (cvt image) mask)) - mask)))))))))]) - (unless ico-icon (printf "no! ~a\n" (icon-desc exe-icon))) - (when ico-icon - (file-position p (car (icon-data exe-icon))) - (display (cdr (icon-data ico-icon)) p))))) - exe-icons)) - (lambda () (close-output-port p)))))) - - ;; ------------------------------ - ;; Image parsing - ;; ------------------------------ - - (define (get-icons file res?) - (let ([p (if (input-port? file) - file - (open-input-file file))]) - (dynamic-wind - void - (lambda () - (unless (= 0 (word->integer p)) - (error 'get-icons "~a doesn't start with 0" file)) - (unless (= 1 (word->integer p)) - (error "type isn't 1")) - (let ([cnt (word->integer p)]) - (let ([icons (let loop ([i 0]) - (if (= i cnt) - null - (cons - (make-icon - (list (byte->integer p) ; w - (byte->integer p) ; h - (byte->integer p) ; colors - (byte->integer p) ; 0 - (word->integer p) ; planes - (word->integer p)) ; bitcount - (list (dword->integer p) ; bytes - ((if res? ; where or icon id - word->integer - dword->integer) - p))) - (loop (add1 i)))))]) - ;; (printf "~a\n" icons) - (for-each (lambda (icon) - (set-icon-data! - icon - (let ([size (car (icon-data icon))] - [where (cadr (icon-data icon))]) - (let ([icon-pos (if res? - ;; last number is icon id: - (car (find-rsrc-start p (format "^3[.]~a[.]" where))) - ;; last number is file position: - where)]) - (file-position p icon-pos) - (cons icon-pos - (read-bytes size p))))) - ;; If colors, planes, and bitcount are all 0, - ;; get the info from the DIB data - (let ([desc (icon-desc icon)]) - (when (and (zero? (list-ref desc 2)) - (zero? (list-ref desc 4)) - (zero? (list-ref desc 5))) - (let ([bi (bitmapinfo icon)]) - (set-icon-desc! icon - (list* - (list-ref desc 0) - (list-ref desc 1) - (list-ref desc 2) - (list-ref desc 3) - (list-ref bi 3) - (list-ref bi 4) - (list-tail desc 6))))))) - icons) - icons))) - (lambda () - (when (path-string? file) - (close-input-port p)))))) - - (define (bitmapinfo icon) - (let ([p (open-input-bytes (cdr (icon-data icon)))]) - (list (dword->integer p) ; size == 40 in practice - (dword->integer p) ; width - (dword->integer p) ; height - (word->integer p) ; planes - (word->integer p) ; bitcount - (dword->integer p) ; compression == 0 - (dword->integer p) ; size image - (dword->integer p) ; x pixels per meter == 0 - (dword->integer p) ; y pixels per meter == 0 - (dword->integer p) ; used == 0 - (dword->integer p)))) ; important == 0 - - ;; Assumes that bits-per-pixel is 1, 2, 4, 8, 24, or 32. - ;; Also assumes that (bits-per-pixel * width) is a multiple of 8. - (define (parse-dib icon) - (let* ([bi (bitmapinfo icon)] - [header-size (list-ref bi 0)] - [num-colors (caddr (icon-desc icon))] - [w (list-ref bi 1)] - [h (/ (list-ref bi 2) 2)] - [bits-per-pixel (list-ref bi 4)]) - (let ([p (open-input-bytes (cdr (icon-data icon)))]) - ;; Skip header - (read-bytes header-size p) - (let* ([read-n - (lambda (n read-one combine) - (let loop ([i n][r null]) - (if (= i 0) - (reverse r) - (loop (sub1 i) - (combine (read-one p) r)))))] - [read-lines - (lambda (w h read-one combine) - (if (zero? (modulo w 4)) - (read-n (* w h) read-one combine) - (let loop ([h h]) - (if (zero? h) - null - (append (read-n w read-one combine) - (begin - ;; pad line to dword: - (read-n (- 4 (modulo w 4)) byte->integer cons) - ;; read next line: - (loop (sub1 h))))))))] - [split-bits (lambda (b) - (list - (bitwise-and b 1) - (arithmetic-shift (bitwise-and b 2) -1) - (arithmetic-shift (bitwise-and b 4) -2) - (arithmetic-shift (bitwise-and b 8) -3) - (arithmetic-shift (bitwise-and b 16) -4) - (arithmetic-shift (bitwise-and b 32) -5) - (arithmetic-shift (bitwise-and b 64) -6) - (arithmetic-shift (bitwise-and b 128) -7)))]) - (let ([main-image - (cond - [(= bits-per-pixel 32) - ;; RGB mode: - (read-n (* w h) dword->integer cons)] - [(= bits-per-pixel 24) - ;; RGB mode: - (read-n (* w h) 3/2word->integer cons)] - [else - ;; Index mode: - (let ([color-table (list->vector - (read-n (if (zero? num-colors) - (arithmetic-shift 1 bits-per-pixel) - num-colors) - dword->integer cons))] - [image (read-lines (/ w (/ 8 bits-per-pixel)) - h - (lambda (p) - (let ([b (byte->integer p)]) - (case bits-per-pixel - [(1) (split-bits b)] - [(2) - (list - (bitwise-and b 3) - (arithmetic-shift (bitwise-and b 12) -2) - (arithmetic-shift (bitwise-and b 48) -4) - (arithmetic-shift (bitwise-and b 192) -6))] - [(4) - (list - (bitwise-and b 15) - (arithmetic-shift (bitwise-and b 240) -4))] - [(8) (list b)]))) - append)]) - (map (lambda (i) (vector-ref color-table i)) image))])]) - (let ([mask (read-lines (/ w 8) - h - (lambda (p) (split-bits (byte->integer p))) - append)]) - (unless (eof-object? (read-char p)) - (error 'parse-dib "not extactly at end")) - (list main-image mask))))))) - - ;; rgb->indexed - ;; The color-reduction strategy isn't great, and because it - ;; depends on hash-table order, it's non-deterministic in - ;; principle. But the actual hash-table implementatin is - ;; deterministic, of course. Also, the re-ordering of the - ;; image via the hash tables tends to produce better - ;; (pseudo-random) representatives of the image for colors. - (define (rgb->indexed image num-colors) - (let ([image (map (lambda (i) (bitwise-and #xFFFFFF i)) image)] ; drop alphas, if any - [table (make-vector num-colors 0)] - [ht (make-hash-table 'equal)] - [map-ht (make-hash-table 'equal)] - [color-dist (lambda (a b) - (sqrt (+ (expt (- (bitwise-and #xFF a) - (bitwise-and #xFF b)) - 2) - (expt (- (arithmetic-shift (bitwise-and #xFF00 a) -8) - (arithmetic-shift (bitwise-and #xFF00 b) -8)) - 2) - (expt (- (arithmetic-shift (bitwise-and #xFF0000 a) -16) - (arithmetic-shift (bitwise-and #xFF0000 b) -16)) - 2))))]) - (for-each (lambda (c) - (hash-table-put! - ht - c - (add1 - (hash-table-get ht c (lambda () 0))))) - image) - (let ([kv-sorted (sort (hash-table-map ht cons) - (lambda (a b) (< (cdr a) (cdr b))))]) - (let ([n 0]) - (for-each (lambda (kv) - (let ([key (car kv)]) - (let ([n (if (< n (sub1 num-colors)) - n - ;; Find closest match: - (let ([n 0]) - (let loop ([i 1]) - (unless (= i num-colors) - (when (< (color-dist key (vector-ref table i)) - (color-dist key (vector-ref table n))) - (set! n i)) - (loop (add1 i)))) - n))]) - (vector-set! table n key) - (hash-table-put! map-ht key n)) - (when (< n (sub1 num-colors)) - (set! n (add1 n))))) - kv-sorted))) - (values (vector->list table) - (map (lambda (c) (hash-table-get map-ht c)) image)))) - - ;; Assumes that bits-per-pixel is 1, 2, 4, 8, or 32. - ;; Also assumes that (bits-per-pixel * width) is a multiple of 8. - (define (build-dib icon image mask) - (let* ([bi (bitmapinfo icon)] - [header-size (list-ref bi 0)] - [num-colors (caddr (icon-desc icon))] - [w (list-ref bi 1)] - [h (/ (list-ref bi 2) 2)] - [bits-per-pixel (list-ref bi 4)]) - (let ([orig-p (open-input-bytes (cdr (icon-data icon)))] - [result-p (open-output-bytes)]) - ;; Copy header: - (display (read-bytes header-size orig-p) result-p) - (let ([get-lines (lambda (image bits-per-pixel) - (map (lambda (line) - ;; pad line to dword boundary - (let ([line-bytes (/ (* w bits-per-pixel) 8)]) - (if (zero? (modulo line-bytes 4)) - line - (append line - (vector->list - (make-vector (* (- 4 (modulo line-bytes 4)) - (/ 8 bits-per-pixel)) - 0)))))) - ;; break out lines - (let loop ([l image]) - (if (null? l) - null - (cons (let loop ([l l][i 0]) - (if (= i w) - null - (cons (car l) (loop (cdr l) (add1 i))))) - (loop (list-tail l w)))))))] - [bits->dwords (lambda (l bpp) - (let ([chunk-size (/ 32 bpp)] - [1byte (lambda (l) - (bitwise-ior - (arithmetic-shift (list-ref l 0) 7) - (arithmetic-shift (list-ref l 1) 6) - (arithmetic-shift (list-ref l 2) 5) - (arithmetic-shift (list-ref l 3) 4) - (arithmetic-shift (list-ref l 4) 3) - (arithmetic-shift (list-ref l 5) 2) - (arithmetic-shift (list-ref l 6) 1) - (arithmetic-shift (list-ref l 7) 0)))] - [2byte (lambda (l) - (bitwise-ior - (arithmetic-shift (list-ref l 0) 6) - (arithmetic-shift (list-ref l 1) 4) - (arithmetic-shift (list-ref l 2) 2) - (arithmetic-shift (list-ref l 3) 0)))] - [4byte (lambda (l) - (bitwise-ior - (arithmetic-shift (list-ref l 0) 4) - (arithmetic-shift (list-ref l 1) 0)))]) - (let loop ([l l]) - (if (null? l) - null - (cons (case bpp - [(1) (bitwise-ior - (arithmetic-shift (1byte (list-tail l 0)) 0) - (arithmetic-shift (1byte (list-tail l 8)) 8) - (arithmetic-shift (1byte (list-tail l 16)) 16) - (arithmetic-shift (1byte (list-tail l 24)) 24))] - [(2) (bitwise-ior - (2byte l) - (arithmetic-shift (2byte (list-tail l 4)) 8) - (arithmetic-shift (2byte (list-tail l 8)) 16) - (arithmetic-shift (2byte (list-tail l 12)) 24))] - [(4) (bitwise-ior - (4byte l) - (arithmetic-shift (4byte (list-tail l 2)) 8) - (arithmetic-shift (4byte (list-tail l 4)) 16) - (arithmetic-shift (4byte (list-tail l 6)) 24))] - [(8) (bitwise-ior - (car l) - (arithmetic-shift (list-ref l 1) 8) - (arithmetic-shift (list-ref l 2) 16) - (arithmetic-shift (list-ref l 3) 24))]) - (loop (list-tail l chunk-size)))))))]) - (if (= bits-per-pixel 32) - (for-each (lambda (col) (integer->dword col result-p)) - image) - (let-values ([(colors indexed-image) (rgb->indexed image (arithmetic-shift 1 bits-per-pixel))]) - ;; color table - (for-each (lambda (col) (integer->dword col result-p)) - colors) - (let* ([lines (get-lines indexed-image bits-per-pixel)] - [dwords (apply append (map (lambda (l) (bits->dwords l bits-per-pixel)) - lines))]) - (for-each (lambda (col) (integer->dword col result-p)) - dwords)))) - (let* ([lines (get-lines mask 1)] - [dwords (apply append (map (lambda (l) (bits->dwords l 1)) lines))]) - (for-each (lambda (col) (integer->dword col result-p)) - dwords)) - (let ([s (get-output-bytes result-p)]) - (unless (= (bytes-length s) (bytes-length (cdr (icon-data icon)))) - (error 'build-dib "bad result size ~a != ~a" - (bytes-length s) (bytes-length (cdr (icon-data icon))))) - s))))) - - (define (parse-icon icon) - (let ([image (parse-dib icon)]) - (list (car (icon-desc icon)) - (cadr (icon-desc icon)) - (let ([cols (caddr (icon-desc icon))]) - (if (zero? cols) - (expt 2 (list-ref (icon-desc icon) 5)) - cols)) - (car image) - (cadr image)))) - - (define (build-icon base-icon image mask) - (make-icon (icon-desc base-icon) - (cons (car (icon-desc base-icon)) - (build-dib base-icon image mask)))) - - (define (extract-icons file) - (if (regexp-match #rx"[.]ico$" (if (path? file) - (path->string file) - file)) - (get-icons-in-ico file) - (get-icons-in-exe file))) - - (define (get-icons-in-ico ico-file) - (get-icons ico-file #f)) - - (define (get-icons-in-exe exe-file) - (let ([p (open-input-file exe-file)]) - (dynamic-wind - void - (lambda () - (let ([pos+size (find-rsrc-start p "^14[.]")]) - (file-position p (car pos+size)) - (get-icons p #t))) - (lambda () (close-input-port p))))) - - ;; The following is useful for bitmap->icon, - ;; but it uses GRacket, and this module is used by - ;; Setup PLT. Probably this code should just be - ;; moved somewhere else. - #; - (begin - (require mred - mzlib/class) - (define (bitmap%->icon bm) - (let* ([w (send bm get-width)] - [h (send bm get-height)] - [argb (make-bytes (* w h 4))] - [mdc (make-object bitmap-dc% bm)]) - (send mdc get-argb-pixels 0 0 w h argb) - (send mdc set-bitmap #f) - ;; Get mask (inverse alpha), if any: - (let ([mask-argb (make-bytes (* w h 4) #o377)] - [mbm (send bm get-loaded-mask)]) - (when mbm - (send mdc set-bitmap mbm) - (send mdc get-argb-pixels 0 0 w h mask-argb) - (send mdc set-bitmap #f)) - (bitmap->icon w h argb mask-argb))))) - - (define (bitmap->icon w h argb mask-argb) - (let ([o (open-output-bytes)]) - (integer->dword 40 o) ; size - (integer->dword w o) ; width - (integer->dword (* 2 h) o) ; height - (integer->word 1 o) ; planes - (integer->word 32 o) ; bitcount - (integer->dword 0 o) ; compression - (integer->dword 0 o) ; size image - (integer->dword 0 o) ; x pixels per meter - (integer->dword 0 o) ; y pixels per meter - (integer->dword 0 o) ; used - (integer->dword 0 o) ; important - ;; Got ARGB, need BGRA - (let* ([flip-pixels (lambda (s) - (let ([s (bytes-copy s)]) - (let loop ([p 0]) - (unless (= p (bytes-length s)) - (let ([a (bytes-ref s p)] - [r (bytes-ref s (+ p 1))] - [g (bytes-ref s (+ p 2))] - [b (bytes-ref s (+ p 3))]) - (bytes-set! s p b) - (bytes-set! s (+ p 1) g) - (bytes-set! s (+ p 2) r) - (bytes-set! s (+ p 3) a) - (loop (+ p 4))))) - s))] - [rgba (flip-pixels argb)] - [mask-rgba (flip-pixels mask-argb)] - [row-size (if (zero? (modulo w 32)) - w - (+ w (- 32 (remainder w 32))))] - [mask (make-bytes (* h row-size 1/8) 0)]) - (let loop ([i (* w h 4)]) - (unless (zero? i) - (let ([mr (bytes-ref mask-rgba (- i 2))] - [mg (bytes-ref mask-rgba (- i 3))] - [mb (bytes-ref mask-rgba (- i 4))] - [a (- i 1)]) - (let ([alpha (- 255 - (floor (/ (+ mr mg mb) - 3)))]) - (if (< alpha 10) - ;; white mask -> zero alpha; add white pixel to mask - (begin - (bytes-set! rgba a 0) - (let ([pos (+ (* (quotient (sub1 (/ i 4)) w) row-size) - (remainder (sub1 (/ i 4)) w))]) - (bytes-set! mask - (quotient pos 8) - (bitwise-ior - (arithmetic-shift 1 (- 7 (remainder pos 8))) - (bytes-ref mask (quotient pos 8)))))) - ;; non-white mask -> non-zero alpha - (bytes-set! rgba a alpha)))) - (loop (- i 4)))) - ;; Windows icons are upside-down: - (let ([flip (lambda (str row-width) - (apply - bytes-append - (reverse - (let loop ([pos 0]) - (if (= pos (bytes-length str)) - null - (cons (subbytes str pos (+ pos row-width)) - (loop (+ pos row-width))))))))]) - (display (flip rgba (* w 4)) o) - (display (flip mask (/ row-size 8)) o)) - (make-icon (list w h 0 0 1 32) - (cons 0 (get-output-bytes o)))))) - - ;; ------------------------------ - ;; Image conversion - ;; ------------------------------ - - (define (mask->alpha image mask) - (map (lambda (i m) - (if (zero? m) - (bitwise-ior #xFF000000 i) - m)) - image mask)) - - (define (first-n n l) - (let loop ([l l][i n]) - (if (zero? i) - null - (cons (car l) (loop (cdr l) (sub1 i)))))) - - (define (16->32 l) - (let loop ([l l]) - (if (null? l) - null - (let ([l2 (let loop ([l (first-n 16 l)]) - (if (null? l) - null - (list* (car l) (car l) (loop (cdr l)))))]) - (append l2 l2 - (loop (list-tail l 16))))))) - - (define (32->48 l) - (let loop ([l l][dup? #t]) - (if (null? l) - null - (let ([l2 (let loop ([l (first-n 32 l)]) - (if (null? l) - null - (list* (car l) (car l) (cadr l) - (loop (cddr l)))))]) - (append l2 - (if dup? l2 null) - (loop (list-tail l 32) (not dup?))))))) - - (define (48->16 l) - (let loop ([l l]) - (if (null? l) - null - (let ([l2 (let loop ([l (first-n 48 l)]) - (if (null? l) - null - (cons (car l) (loop (cdddr l)))))]) - (append l2 - (loop (list-tail l 144))))))) - - (define (48->32 l) - (let loop ([l l][step 0]) - (if (null? l) - null - (let ([l2 (let loop ([l (first-n 48 l)][step 0]) - (if (null? l) - null - (if (= 1 (modulo step 3)) - (loop (cdr l) 2) - (cons (car l) (loop (cdr l) (add1 step))))))]) - (append (if (= 1 (modulo step 3)) null l2) - (loop (list-tail l 48) (add1 step)))))))) - -#| - -;; ---------------------------------------- -;; Test code - -(define icons (extract-icons "e:/matthew/plt/mred.exe")) - -(define (show-icon w h col-count image mask) - (let* ([f (make-object frame% (format "~a x ~a (~a) Image" w h col-count))] - [bm (make-object bitmap% w h)] - [mbm (make-object bitmap% w h)] - [c (instantiate canvas% (f) - [paint-callback (lambda (c dc) - (send dc draw-bitmap bm 0 0) - (send dc draw-bitmap mbm w 0))])]) - (let ([mdc (make-object bitmap-dc% bm)] - [col (make-object color%)]) - (let loop ([l image][i 0][j 0]) - (unless (= j h) - (let ([v (car l)]) - (send col set - (bitwise-and v #xFF) - (arithmetic-shift (bitwise-and v #xFF00) -8) - (arithmetic-shift (bitwise-and v #xFF0000) -16)) - (send mdc set-pixel i j col) - (if (= (add1 i) w) - (loop (cdr l) 0 (add1 j)) - (loop (cdr l) (add1 i) j))))) - (send mdc set-bitmap mbm) - (let loop ([l (if (col-count . > . 256) image mask)][i 0][j 0]) - (unless (= j h) - (let ([v (if (col-count . > . 256) - (- 255 (arithmetic-shift (bitwise-and (car l) #xFF000000) -24)) - (if (zero? (car l)) - 0 - 255))]) - (send col set v v v) - (send mdc set-pixel i j col) - (if (= (add1 i) w) - (loop (cdr l) 0 (add1 j)) - (loop (cdr l) (add1 i) j))))) - - (send mdc set-bitmap #f)) - (send c min-client-width (* 2 w)) - (send c min-client-height h) - (send c stretchable-width #f) - (send c stretchable-height #f) - - (send f show #t))) - -(define (find-icon icons w h colors) - (ormap (lambda (i) - (let ([p (parse-icon i)]) - (and (= w (car p)) - (= h (cadr p)) - (= colors (caddr p)) - i))) - icons)) - -(let ([orig (find-icon icons 48 48 (expt 2 32))] - [target (find-icon icons 32 32 256)]) - (apply show-icon (parse-icon orig)) - (apply show-icon (parse-icon target)) - (apply show-icon - (parse-icon - (let* ([p (parse-icon orig)] - [mask (48->32(list-ref p 4))] - [image (mask->alpha (48->32 (list-ref p 3)) mask)]) - (build-icon target image mask))))) - -;; ---------------------------------------- -;; End test code - -|# diff --git a/collects/file/ico.rkt b/collects/file/ico.rkt new file mode 100644 index 0000000000..3e3a8367ca --- /dev/null +++ b/collects/file/ico.rkt @@ -0,0 +1,806 @@ +#lang racket/base +(require racket/contract) + +(provide ico? + (contract-out + [ico-width (ico? . -> . (integer-in 1 256))] + [ico-height (ico? . -> . (integer-in 1 256))] + [ico-depth (ico? . -> . (one-of/c 1 2 4 8 16 24 32))] + + [read-icos ((or/c path-string? input-port?) . -> . (listof ico?))] + [read-icos-from-exe ((or/c path-string? input-port?) . -> . (listof ico?))] + + [write-icos ([(listof ico?) (or/c path-string? output-port?)] + [#:exists (or/c 'error 'append 'update 'can-update + 'replace 'truncate + 'must-truncate 'truncate/replace)] + . ->* . + void?)] + [replace-icos ((listof ico?) (or/c path-string? output-port?) + . -> . void?)] + + [ico->argb (ico? . -> . bytes?)] + [argb->ico ([(integer-in 1 256) (integer-in 1 256) bytes? ] + [#:depth (one-of/c 1 2 4 8 24 32)] + . ->* . + ico?)])) + +;; parse-ico build-ico + +(define (byte->integer p) + (read-byte p)) +(define (word->integer p) + (integer-bytes->integer (read-bytes 2 p) #f #f)) +(define (dword->integer p) + (integer-bytes->integer (read-bytes 4 p) #f #f)) + +;; The 0 added in the alpha position apparently means "ignore the alpha +;; and use the mask, instead" +(define (3/2word->integer p) + (integer-bytes->integer (bytes-append (read-bytes 3 p) #"\0") #f #f)) + +(define (integer->word i p) + (display (integer->integer-bytes i 2 #f #f) p)) +(define (integer->dword i p) + (display (integer->integer-bytes i 4 #f #f) p)) +(define (integer->3/2word i p) + (display (subbytes (integer->integer-bytes i 4 #f #f) 0 3) p)) + +(define (flag v) + (positive? (bitwise-and #x80000000 v))) +(define (value v) + (bitwise-and #x7FFFFFFF v)) + +(define (skip-to-image-headers-after-signature p) + ;; p is expected to be a file port + (file-position p 60) + (let ([pos (word->integer p)]) + ;; pos points to IMAGE_NT_HEADERS + (file-position p pos) + (unless (= #x4550 (dword->integer p)) + (error "bad signature")) + pos)) + +(define (get-image-base p) + (let ([pos (skip-to-image-headers-after-signature p)]) + (file-position p (+ 4 + 20 + 28)) + (dword->integer p))) + +(define (find-section p find-name) + (let ([pos (skip-to-image-headers-after-signature p)]) + (word->integer p) ; skip machine + (let ([num-sections (word->integer p)] + [_ (begin (dword->integer p) + (dword->integer p) + (dword->integer p))] + [size (word->integer p)]) + (let ([pos (+ pos + 4 ; Signature : DWORD + 20 ; FileHeader: IMAGE_FILE_HEADER + size)]) ; "optional" header + (let sloop ([section 0][section-pos pos]) + (if (= section num-sections) + (error 'find-section "can't find section: ~e" find-name) + (begin + (file-position p section-pos) + ;; p points to an IMAGE_SECTION_HEADER + (let ([name (read-bytes 8 p)]) + (if (bytes=? find-name name) + (let ([_ (dword->integer p)]) ; skip + (values (dword->integer p) ; virtual address + (dword->integer p) ; length + (dword->integer p))); file pos + (sloop (add1 section) (+ section-pos 40))))))))))) + +(define (find-rsrc-start p re:rsrc) + (let-values ([(rsrc-virtual-addr rsrc-len rsrc-pos) + (find-section p #".rsrc\0\0\0")]) + (let loop ([dir-pos 0][path ""]) + (file-position p (+ rsrc-pos dir-pos 12)) + (let ([num-named (word->integer p)] + [num-ided (word->integer p)]) + (let iloop ([i 0]) + (if (= i (+ num-ided num-named)) + #f + (let ([name-delta (dword->integer p)] + [data-delta (dword->integer p)] + [next (file-position p)]) + (or (let ([name (if (flag name-delta) + (begin + (file-position p (+ rsrc-pos (value name-delta))) + (let* ([len (word->integer p)]) + ;; len is in unicode chars... + (let ([unistr (read-bytes (* 2 len) p)]) + ;; Assume it fits into ASCII... + (regexp-replace* "\0" + (bytes->string/latin-1 unistr) + "")))) + (value name-delta))]) + ;;(printf "Name: ~a~a = ~a\n" path name (+ rsrc-pos (value data-delta))) + (let ([full-name (format "~a~a" path name)]) + (if (flag data-delta) + (loop (value data-delta) (string-append full-name ".")) + ;; Found the icon? + (and (regexp-match re:rsrc full-name) + ;; Yes, so read IMAGE_RESOURCE_DATA_ENTRY + (begin + (file-position p (+ rsrc-pos (value data-delta))) + (cons + (+ (dword->integer p) ; offset (an RVA) + (- rsrc-pos + rsrc-virtual-addr)) + (dword->integer p))))))) ; size + (begin + (file-position p next) + (iloop (add1 i))))))))))) + +(define-struct ico (desc data) #:mutable) +;; desc is (list width height colors 0 planes bitcount) +;; data is (cons pos bytes) + +(define (ico-width i) (let ([v (car (ico-desc i))]) + (if (= v 0) + 256 + v))) +(define (ico-height i) (let ([v (cadr (ico-desc i))]) + (if (= v 0) + 256 + v))) +(define (ico-depth i) + (let ([cols (caddr (ico-desc i))]) + (if (zero? cols) + (list-ref (ico-desc i) 5) + (integer-length (sub1 cols))))) +(define (ico-colors i) (num-colors (ico-desc i))) + +(define (num-colors l) + (let ([n (caddr l)]) + (if (zero? n) + (arithmetic-shift 1 (list-ref l 5)) + n))) + +(define (replace-icos ico-icos exe-file) + (let ([exe-icos (read-icos-from-exe exe-file)]) + (let ([p (open-output-file exe-file #:exists 'update)]) + (dynamic-wind + void + (lambda () + (for-each (lambda (exe-ico) + (let ([best-ico-ico + ;; Find exact match? + (ormap (lambda (ico-ico) + (let ([le (ico-desc exe-ico)] + [li (ico-desc ico-ico)]) + (and (= (car li) (car le)) + (= (cadr li) (cadr le)) + (= (num-colors li) (num-colors le)) + (= (bytes-length (cdr (ico-data exe-ico))) + (bytes-length (cdr (ico-data ico-ico)))) + ico-ico))) + ico-icos)]) + (let ([ico-ico (or best-ico-ico + ;; Look for a conversion, if we + ;; need a 16x16, 32x32, or 48x48 + ;; ico + (and + (= (car (ico-desc exe-ico)) + (cadr (ico-desc exe-ico))) + (memq (car (ico-desc exe-ico)) + '(16 32 48)) + (let ([biggest-colorest #f]) + (for-each + (lambda (ico-ico) + (let ([w (ico-width ico-ico)] + [exew (ico-width exe-ico)]) + (when (and + (= w (ico-width ico-ico)) + (memq w '(16 32 48)) + (or + (not biggest-colorest) + (and (= w exew) + (not (= exew (ico-width biggest-colorest)))) + (and (= w exew) + (> (num-colors (ico-desc ico-ico)) + (num-colors (ico-desc biggest-colorest)))) + (and (not (= exew (ico-width biggest-colorest))) + (or (> w (ico-width biggest-colorest)) + (> (num-colors (ico-desc ico-ico)) + (num-colors (ico-desc biggest-colorest))))))) + (set! biggest-colorest ico-ico)))) + ico-icos) + (and + biggest-colorest + ;; Convert... + (let* ([src-size (ico-width biggest-colorest)] + [dest-size (ico-width exe-ico)] + [src (parse-ico biggest-colorest)] + [image (list-ref src 3)] + [mask (list-ref src 4)] + [has-alpha? (<= 256 (num-colors (ico-desc biggest-colorest)))]) + (if (= src-size dest-size) + (build-ico exe-ico + (if has-alpha? + image + (mask->alpha image mask)) + mask + #t) + (let ([cvt + (cond + [(and (= src-size 32) (= dest-size 16)) + (lambda (i) (48->16 (32->48 i)))] + [(and (= src-size 32) (= dest-size 48)) + 32->48] + [(and (= src-size 48) (= dest-size 16)) + 48->16] + [(and (= src-size 48) (= dest-size 32)) + 48->32] + [(and (= src-size 16) (= dest-size 32)) + 16->32] + [(and (= src-size 16) (= dest-size 48)) + (lambda (i) (32->48 (16->32 i)))])]) + (let ([mask (cvt mask)]) + (build-ico exe-ico + (if has-alpha? + image + (mask->alpha (cvt image) mask)) + mask + #t)))))))))]) + (unless ico-ico (printf "no! ~a\n" (ico-desc exe-ico))) + (when ico-ico + (file-position p (car (ico-data exe-ico))) + (display (cdr (ico-data ico-ico)) p))))) + exe-icos)) + (lambda () (close-output-port p)))))) + +;; ------------------------------ +;; Image parsing +;; ------------------------------ + +(define (get-icos file res?) + (let ([p (if (input-port? file) + file + (open-input-file file))]) + (dynamic-wind + void + (lambda () + (unless (= 0 (word->integer p)) + (error 'get-icos "~a doesn't start with 0" file)) + (unless (= 1 (word->integer p)) + (error "type isn't 1")) + (let ([cnt (word->integer p)]) + (let ([icos (let loop ([i 0]) + (if (= i cnt) + null + (cons + (make-ico + (list (byte->integer p) ; w + (byte->integer p) ; h + (byte->integer p) ; colors + (byte->integer p) ; 0 + (word->integer p) ; planes + (word->integer p)) ; bitcount + (list (dword->integer p) ; bytes + ((if res? ; where or icon id + word->integer + dword->integer) + p))) + (loop (add1 i)))))]) + ;; (printf "~a\n" icos) + (for-each (lambda (ico) + (set-ico-data! + ico + (let ([size (car (ico-data ico))] + [where (cadr (ico-data ico))]) + (let ([ico-pos (if res? + ;; last number is icon id: + (car (find-rsrc-start p (regexp (format "^3[.]~a[.]" where)))) + ;; last number is file position: + where)]) + (file-position p ico-pos) + (cons ico-pos + (read-bytes size p))))) + ;; If colors, planes, and bitcount are all 0, + ;; get the info from the DIB data + (let ([desc (ico-desc ico)]) + (when (and (zero? (list-ref desc 2)) + (zero? (list-ref desc 4)) + (zero? (list-ref desc 5))) + (let ([bi (bitmapinfo ico)]) + (set-ico-desc! ico + (list* + (list-ref desc 0) + (list-ref desc 1) + (list-ref desc 2) + (list-ref desc 3) + (list-ref bi 3) + (list-ref bi 4) + (list-tail desc 6))))))) + icos) + icos))) + (lambda () + (when (path-string? file) + (close-input-port p)))))) + +(define (bitmapinfo ico) + (let ([p (open-input-bytes (cdr (ico-data ico)))]) + (list (dword->integer p) ; size == 40 in practice + (dword->integer p) ; width + (dword->integer p) ; height + (word->integer p) ; planes + (word->integer p) ; bitcount + (dword->integer p) ; compression == 0 + (dword->integer p) ; size image + (dword->integer p) ; x pixels per meter == 0 + (dword->integer p) ; y pixels per meter == 0 + (dword->integer p) ; used == 0 + (dword->integer p)))) ; important == 0 + +;; Assumes that bits-per-pixel is 1, 2, 4, 8, 16, 24, or 32. +;; Also assumes that (bits-per-pixel * width) is a multiple of 8. +(define (parse-dib ico) + (let* ([bi (bitmapinfo ico)] + [header-size (list-ref bi 0)] + [num-colors (caddr (ico-desc ico))] + [w (list-ref bi 1)] + [h (/ (list-ref bi 2) 2)] + [bits-per-pixel (list-ref bi 4)]) + (let ([p (open-input-bytes (cdr (ico-data ico)))]) + ;; Skip header + (read-bytes header-size p) + (let* ([read-n + (lambda (n read-one combine) + (let loop ([i n][r null]) + (if (= i 0) + (reverse r) + (loop (sub1 i) + (combine (read-one p) r)))))] + [read-lines + (lambda (w h read-one combine) + (if (zero? (modulo w 4)) + (read-n (* w h) read-one combine) + (let loop ([h h]) + (if (zero? h) + null + (append (read-n w read-one combine) + (begin + ;; pad line to dword: + (read-n (- 4 (modulo w 4)) byte->integer cons) + ;; read next line: + (loop (sub1 h))))))))] + [split-bits (lambda (b) + (list + (bitwise-and b 1) + (arithmetic-shift (bitwise-and b 2) -1) + (arithmetic-shift (bitwise-and b 4) -2) + (arithmetic-shift (bitwise-and b 8) -3) + (arithmetic-shift (bitwise-and b 16) -4) + (arithmetic-shift (bitwise-and b 32) -5) + (arithmetic-shift (bitwise-and b 64) -6) + (arithmetic-shift (bitwise-and b 128) -7)))]) + (let ([main-image + (cond + [(= bits-per-pixel 32) + ;; RGB mode: + (read-n (* w h) dword->integer cons)] + [(= bits-per-pixel 24) + ;; RGB mode: + (read-n (* w h) 3/2word->integer cons)] + [else + ;; Index mode: + (let ([color-table (list->vector + (read-n (if (zero? num-colors) + (arithmetic-shift 1 bits-per-pixel) + num-colors) + dword->integer cons))] + [image (read-lines (/ w (/ 8 bits-per-pixel)) + h + (lambda (p) + (let ([b (byte->integer p)]) + (case bits-per-pixel + [(1) (split-bits b)] + [(2) + (list + (bitwise-and b 3) + (arithmetic-shift (bitwise-and b 12) -2) + (arithmetic-shift (bitwise-and b 48) -4) + (arithmetic-shift (bitwise-and b 192) -6))] + [(4) + (list + (bitwise-and b 15) + (arithmetic-shift (bitwise-and b 240) -4))] + [(8) (list b)]))) + append)]) + (map (lambda (i) (vector-ref color-table i)) image))])]) + (let ([mask (read-lines (/ w 8) + h + (lambda (p) (split-bits (byte->integer p))) + append)]) + (unless (eof-object? (read-byte p)) + (error 'parse-dib "not extactly at end")) + (list main-image mask))))))) + +;; rgb->indexed +;; The color-reduction strategy isn't great, and because it +;; depends on hash-table order, it's non-deterministic in +;; principle. But the actual hash-table implementation is +;; deterministic, of course. Also, the re-ordering of the +;; image via the hash tables tends to produce better +;; (pseudo-random) representatives of the image for colors. +(define (rgb->indexed image num-colors) + (let ([image (map (lambda (i) (bitwise-and #xFFFFFF i)) image)] ; drop alphas, if any + [table (make-vector num-colors 0)] + [ht (make-hash)] + [map-ht (make-hash)] + [color-dist (lambda (a b) + (sqrt (+ (expt (- (bitwise-and #xFF a) + (bitwise-and #xFF b)) + 2) + (expt (- (arithmetic-shift (bitwise-and #xFF00 a) -8) + (arithmetic-shift (bitwise-and #xFF00 b) -8)) + 2) + (expt (- (arithmetic-shift (bitwise-and #xFF0000 a) -16) + (arithmetic-shift (bitwise-and #xFF0000 b) -16)) + 2))))]) + (for-each (lambda (c) + (hash-set! + ht + c + (add1 + (hash-ref ht c 0)))) + image) + (let ([kv-sorted (sort (hash-map ht cons) + (lambda (a b) (< (cdr a) (cdr b))))]) + (let ([n 0]) + (for-each (lambda (kv) + (let ([key (car kv)]) + (let ([n (if (< n (sub1 num-colors)) + n + ;; Find closest match: + (let ([n 0]) + (let loop ([i 1]) + (unless (= i num-colors) + (when (< (color-dist key (vector-ref table i)) + (color-dist key (vector-ref table n))) + (set! n i)) + (loop (add1 i)))) + n))]) + (vector-set! table n key) + (hash-set! map-ht key n)) + (when (< n (sub1 num-colors)) + (set! n (add1 n))))) + kv-sorted))) + (values (vector->list table) + (map (lambda (c) (hash-ref map-ht c)) image)))) + +;; Assumes that bits-per-pixel is 1, 2, 4, 8, or 32. +;; Also assumes that (bits-per-pixel * width) is a multiple of 8. +(define (build-dib ico image mask check?) + (let* ([bi (bitmapinfo ico)] + [header-size (list-ref bi 0)] + [num-colors (caddr (ico-desc ico))] + [w (list-ref bi 1)] + [h (/ (list-ref bi 2) 2)] + [bits-per-pixel (list-ref bi 4)]) + (let ([orig-p (open-input-bytes (cdr (ico-data ico)))] + [result-p (open-output-bytes)]) + ;; Copy header: + (display (read-bytes header-size orig-p) result-p) + (let ([get-lines (lambda (image bits-per-pixel) + (map (lambda (line) + ;; pad line to dword boundary + (let ([line-bytes (/ (* w bits-per-pixel) 8)]) + (if (zero? (modulo line-bytes 4)) + line + (append line + (vector->list + (make-vector (* (- 4 (modulo line-bytes 4)) + (/ 8 bits-per-pixel)) + 0)))))) + ;; break out lines + (let loop ([l image]) + (if (null? l) + null + (cons (let loop ([l l][i 0]) + (if (= i w) + null + (cons (car l) (loop (cdr l) (add1 i))))) + (loop (list-tail l w)))))))] + [bits->dwords (lambda (l bpp) + (let ([chunk-size (/ 32 bpp)] + [1byte (lambda (l) + (bitwise-ior + (arithmetic-shift (list-ref l 0) 7) + (arithmetic-shift (list-ref l 1) 6) + (arithmetic-shift (list-ref l 2) 5) + (arithmetic-shift (list-ref l 3) 4) + (arithmetic-shift (list-ref l 4) 3) + (arithmetic-shift (list-ref l 5) 2) + (arithmetic-shift (list-ref l 6) 1) + (arithmetic-shift (list-ref l 7) 0)))] + [2byte (lambda (l) + (bitwise-ior + (arithmetic-shift (list-ref l 0) 6) + (arithmetic-shift (list-ref l 1) 4) + (arithmetic-shift (list-ref l 2) 2) + (arithmetic-shift (list-ref l 3) 0)))] + [4byte (lambda (l) + (bitwise-ior + (arithmetic-shift (list-ref l 0) 4) + (arithmetic-shift (list-ref l 1) 0)))]) + (let loop ([l l]) + (if (null? l) + null + (cons (case bpp + [(1) (bitwise-ior + (arithmetic-shift (1byte (list-tail l 0)) 0) + (arithmetic-shift (1byte (list-tail l 8)) 8) + (arithmetic-shift (1byte (list-tail l 16)) 16) + (arithmetic-shift (1byte (list-tail l 24)) 24))] + [(2) (bitwise-ior + (2byte l) + (arithmetic-shift (2byte (list-tail l 4)) 8) + (arithmetic-shift (2byte (list-tail l 8)) 16) + (arithmetic-shift (2byte (list-tail l 12)) 24))] + [(4) (bitwise-ior + (4byte l) + (arithmetic-shift (4byte (list-tail l 2)) 8) + (arithmetic-shift (4byte (list-tail l 4)) 16) + (arithmetic-shift (4byte (list-tail l 6)) 24))] + [(8) (bitwise-ior + (car l) + (arithmetic-shift (list-ref l 1) 8) + (arithmetic-shift (list-ref l 2) 16) + (arithmetic-shift (list-ref l 3) 24))]) + (loop (list-tail l chunk-size)))))))]) + (cond + [(= bits-per-pixel 32) + (for-each (lambda (col) (integer->dword col result-p)) + image)] + [(= bits-per-pixel 24) + (for-each (lambda (col) (integer->3/2word col result-p)) + image)] + [else + (let-values ([(colors indexed-image) (rgb->indexed image (arithmetic-shift 1 bits-per-pixel))]) + ;; color table + (for-each (lambda (col) (integer->dword col result-p)) + colors) + (let* ([lines (get-lines indexed-image bits-per-pixel)] + [dwords (apply append (map (lambda (l) (bits->dwords l bits-per-pixel)) + lines))]) + (for-each (lambda (col) (integer->dword col result-p)) + dwords)))]) + (let* ([lines (get-lines mask 1)] + [dwords (apply append (map (lambda (l) (bits->dwords l 1)) lines))]) + (for-each (lambda (col) (integer->dword col result-p)) + dwords)) + (let ([s (get-output-bytes result-p)]) + (when check? + (unless (= (bytes-length s) (bytes-length (cdr (ico-data ico)))) + (error 'build-dib "bad result size ~a != ~a" + (bytes-length s) (bytes-length (cdr (ico-data ico)))))) + s))))) + +(define (parse-ico ico) + (let ([image (parse-dib ico)]) + (list (ico-width ico) + (ico-height ico) + (ico-colors ico) + (car image) ; list of image pixels + (cadr image)))) ; list of mask pixels + +(define (ico->argb ico) + (let* ([image (parse-ico ico)] + [pixels (list-ref image 3)] + [len (length pixels)] + [bstr (make-bytes (* 4 len))] + [w (ico-width ico)] + [h (ico-height ico)] + [has-alpha? (= 32 (ico-depth ico))]) + (for ([p (in-list pixels)] + [m (in-list (list-ref image 4))] + [i (in-naturals)]) + (let* ([y (- h (quotient i w) 1)] + [x (modulo i w)] + [i (+ x (* w y))]) + (bytes-set! bstr (+ 0 (* i 4)) (if has-alpha? + (bitwise-and #xff (arithmetic-shift p -24)) + (if (zero? m) 255 0))) + (bytes-set! bstr (+ 1 (* i 4)) (bitwise-and #xff (arithmetic-shift p -16))) + (bytes-set! bstr (+ 2 (* i 4)) (bitwise-and #xff (arithmetic-shift p -8))) + (bytes-set! bstr (+ 3 (* i 4)) (bitwise-and #xff p)))) + bstr)) + +(define (build-ico base-ico image mask check?) + (make-ico (ico-desc base-ico) + (cons (car (ico-data base-ico)) + (build-dib base-ico image mask check?)))) + +(define (read-icos ico-file) + (get-icos ico-file #f)) + +(define (read-icos-from-exe exe-file) + (let ([p (open-input-file exe-file)]) + (dynamic-wind + void + (lambda () + (let ([pos+size (find-rsrc-start p #rx"^14[.]")]) + (file-position p (car pos+size)) + (get-icos p #t))) + (lambda () (close-input-port p))))) + +(define (write-header w h depth o) + (integer->dword 40 o) ; size + (integer->dword w o) ; width + (integer->dword (* 2 h) o) ; height + (integer->word 1 o) ; planes + (integer->word depth o) ; bitcount + (integer->dword 0 o) ; compression + (integer->dword 0 o) ; size image + (integer->dword 0 o) ; x pixels per meter + (integer->dword 0 o) ; y pixels per meter + (integer->dword 0 o) ; used + (integer->dword 0 o)) ; important + +(define (argb->ico w h argb #:depth [depth 32]) + (let ([o (open-output-bytes)]) + (write-header w h 32 o) + ;; Got ARGB, need BGRA + (let* ([flip-pixels (lambda (s) + (let ([s (bytes-copy s)]) + (let loop ([p 0]) + (unless (= p (bytes-length s)) + (let ([a (bytes-ref s p)] + [r (bytes-ref s (+ p 1))] + [g (bytes-ref s (+ p 2))] + [b (bytes-ref s (+ p 3))]) + (bytes-set! s p b) + (bytes-set! s (+ p 1) g) + (bytes-set! s (+ p 2) r) + (bytes-set! s (+ p 3) a) + (loop (+ p 4))))) + s))] + [rgba (flip-pixels argb)] + [row-size (if (zero? (modulo w 32)) + w + (+ w (- 32 (remainder w 32))))] + [mask (make-bytes (* h row-size 1/8) 0)]) + (let loop ([i (* w h 4)]) + (unless (zero? i) + (let ([alpha (bytes-ref rgba (- i 1))]) + (when (< alpha 10) + ;; white mask -> zero alpha; add white pixel to mask + (bytes-set! rgba (- i 1) 0) + (let ([pos (+ (* (quotient (sub1 (/ i 4)) w) row-size) + (remainder (sub1 (/ i 4)) w))]) + (bytes-set! mask + (quotient pos 8) + (bitwise-ior + (arithmetic-shift 1 (- 7 (remainder pos 8))) + (bytes-ref mask (quotient pos 8))))))) + (loop (- i 4)))) + ;; Windows icos are upside-down: + (let ([flip (lambda (str row-width) + (apply + bytes-append + (reverse + (let loop ([pos 0]) + (if (= pos (bytes-length str)) + null + (cons (subbytes str pos (+ pos row-width)) + (loop (+ pos row-width))))))))]) + (display (flip rgba (* w 4)) o) + (display (flip mask (/ row-size 8)) o)) + (define (256->0 v) (if (= v 256) 0 v)) + (let ([ico (make-ico (list (256->0 w) (256->0 h) 0 0 1 32) + (cons 0 (get-output-bytes o)))]) + (cond + [(= depth 32) ico] + [else (let ([o (open-output-bytes)]) + (write-header w h depth o) + (define image (parse-dib ico)) + (build-ico (make-ico (list (256->0 w) (256->0 h) + (if (depth . <= . 8) + (256->0 (expt 2 depth)) + 0) + 0 1 depth) + (cons 0 (get-output-bytes o))) + (car image) + (cadr image) + #f))]))))) + + +(define (write-icos icos file #:exists [exists 'error]) + (let ([p #f]) + (dynamic-wind + (lambda () + (set! p (if (output-port? file) + file + (open-output-file file #:exists exists)))) + (lambda () + (integer->word 0 p) + (integer->word 1 p) ; 1 = icon + (define count (length icos)) + (integer->word count p) + (for/fold ([offset (+ 6 (* 16 count))]) ([i (in-list icos)]) + (define size (bytes-length (cdr (ico-data i)))) + (write-byte (car (ico-desc i)) p) + (write-byte (cadr (ico-desc i)) p) + (write-byte (list-ref (ico-desc i) 2) p) + (write-byte 0 p) + (integer->word (list-ref (ico-desc i) 4) p) + (integer->word (list-ref (ico-desc i) 5) p) + (integer->dword size p) + (integer->dword offset p) + (+ offset size)) + (for ([i (in-list icos)]) + (write-bytes (cdr (ico-data i)) p))) + (lambda () + (unless (output-port? file) + (close-output-port p)))))) + +;; ------------------------------ +;; Image conversion +;; ------------------------------ + +(define (mask->alpha image mask) + (map (lambda (i m) + (if (zero? m) + (bitwise-ior #xFF000000 i) + m)) + image mask)) + +(define (first-n n l) + (let loop ([l l][i n]) + (if (zero? i) + null + (cons (car l) (loop (cdr l) (sub1 i)))))) + +(define (16->32 l) + (let loop ([l l]) + (if (null? l) + null + (let ([l2 (let loop ([l (first-n 16 l)]) + (if (null? l) + null + (list* (car l) (car l) (loop (cdr l)))))]) + (append l2 l2 + (loop (list-tail l 16))))))) + +(define (32->48 l) + (let loop ([l l][dup? #t]) + (if (null? l) + null + (let ([l2 (let loop ([l (first-n 32 l)]) + (if (null? l) + null + (list* (car l) (car l) (cadr l) + (loop (cddr l)))))]) + (append l2 + (if dup? l2 null) + (loop (list-tail l 32) (not dup?))))))) + +(define (48->16 l) + (let loop ([l l]) + (if (null? l) + null + (let ([l2 (let loop ([l (first-n 48 l)]) + (if (null? l) + null + (cons (car l) (loop (cdddr l)))))]) + (append l2 + (loop (list-tail l 144))))))) + +(define (48->32 l) + (let loop ([l l][step 0]) + (if (null? l) + null + (let ([l2 (let loop ([l (first-n 48 l)][step 0]) + (if (null? l) + null + (if (= 1 (modulo step 3)) + (loop (cdr l) 2) + (cons (car l) (loop (cdr l) (add1 step))))))]) + (append (if (= 1 (modulo step 3)) null l2) + (loop (list-tail l 48) (add1 step))))))) diff --git a/collects/file/scribblings/file.scrbl b/collects/file/scribblings/file.scrbl index 607d10b334..d2046036dd 100644 --- a/collects/file/scribblings/file.scrbl +++ b/collects/file/scribblings/file.scrbl @@ -13,6 +13,7 @@ @include-section["md5.scrbl"] @include-section["sha1.scrbl"] @include-section["gif.scrbl"] +@include-section["ico.scrbl"] @include-section["resource.scrbl"] @(bibliography diff --git a/collects/file/scribblings/ico.scrbl b/collects/file/scribblings/ico.scrbl new file mode 100644 index 0000000000..4dc69cbb37 --- /dev/null +++ b/collects/file/scribblings/ico.scrbl @@ -0,0 +1,79 @@ +#lang scribble/doc +@(require "common.rkt" (for-label file/ico)) + +@title[#:tag "ico"]{ICO File Reading and Writing} + +@defmodule[file/ico] + +The @racketmodname[file/ico] library provides functions for reading +and writing @filepath{.ico} files, which contain one or more icons. +Each icon is up to 256 by 256 pixels, has a particular depth (i.e., +bits per pixel used to represent a color), and mask (i.e., whether a +pixel is shown, except that the mask may be ignored for 32-bit icons +that have an alpha value per pixel). + +@defproc[(ico? [v any/c]) boolean?]{ + +Returns @racket[#t] if @racket[v] represents an icon, @racket[#f] +otherwise.} + +@deftogether[( +@defproc[(ico-width [ico ico?]) (integer-in 1 256)] +@defproc[(ico-height [ico ico?]) (integer-in 1 256)] +@defproc[(ico-depth [ico ico?]) (one-of/c 1 2 4 8 16 24 32)] +)]{ + +Returns the width or of an icon in pixels, or the depth in bits per +pixel.} + +@defproc[(read-icos [src (or/c path-string? input-port?)]) + (listof ico?)]{ + +Parses @racket[src] as an @filepath{.ico} to extract a list of icons.} + +@defproc[(read-icos-from-exe [src (or/c path-string? input-port?)]) + (listof ico?)]{ + +Parses @racket[src] as an @filepath{.exe} to extract the list of +icons that represent the Windows executable.} + +@defproc[(write-icos [icos (listof ico?)] + [dest (or/c path-string? output-port?)] + [#:exists exists (or/c 'error 'append 'update 'can-update + 'replace 'truncate + 'must-truncate 'truncate/replace) + 'error]) + void?]{ + +Writes each icon in @racket[icos] to @racket[dest] as an +@filepath{.ico} file. If @racket[dest] is not an output port, +@racket[exists] is passed on to @racket[open-output-file] to open +@racket[dest] for writing.} + +@defproc[(replace-icos [icos (listof ico?)] + [dest (or/c path-string? output-port?)]) + void?]{ + +Writes icons in @racket[icos] to replace icons in @racket[dest] as an +Windows executable. Only existing icon sizes and depths in the +executable are replaced, and best matches for the existing sizes and +depth are drawn from @racket[icos] (adjusting the scale and depth f a +best match as necessary).} + +@defproc[(ico->argb [ico ico?]) bytes?]{ + +Converts an icon to an ARGB byte string, which has the icon's pixels +in left-to-right, top-to-bottom order, with four bytes (alpha, red, +green, and blue channels) for each pixel.} + +@defproc[(argb->ico [width (integer-in 1 256)] + [height (integer-in 1 256)] + [bstr bytes?] + [#:depth depth (one-of/c 1 2 4 8 24 32) 32]) + ico?]{ + +Converts an ARGB byte string (in the same format as from +@racket[ico->argb]) to an icon of the given width, height, and depth. + +The @racket[bstr] argument must have a length @racket[(* 4 width height)], +and @racket[(* width depth)] must be a multiple of 8.}