file/ico: support PNG icons and arbitrary icon-set replacement
Support PNG-encoded icons in ".ico" files and executables. For executables, instead of supporting only new icons that match the sizes and encodings of existing icons in an executable, support arbitrary replacement icons in an executable. The improved funcitonality relies on a new library (currently private) for general updates to a Windows executable's resources.
This commit is contained in:
Matthew Flatt
parent
b9a5e92c37
commit
e2b27be099
|
|
@ -10,7 +10,8 @@ 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).
|
||||
that have an alpha value per pixel). The library also provides support
|
||||
for reading and writing icons in Windows executables.
|
||||
|
||||
@defproc[(ico? [v any/c]) boolean?]{
|
||||
|
||||
|
|
@ -18,25 +19,40 @@ 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-width [ico ico?]) exact-positive-integer?]
|
||||
@defproc[(ico-height [ico ico?]) exact-positive-integer?]
|
||||
@defproc[(ico-depth [ico ico?]) (one-of/c 1 2 4 8 16 24 32)]
|
||||
)]{
|
||||
|
||||
Returns the width or height of an icon in pixels, or the depth in bits per
|
||||
pixel.}
|
||||
pixel.
|
||||
|
||||
@history[#:changed "6.2.900.10" @elem{A PNG-format icon can have a
|
||||
width or height greater than 256.}]}
|
||||
|
||||
|
||||
@deftogether[(
|
||||
@defproc[(ico-format [ico ico?]) (or/c 'bmp 'png)]
|
||||
)]{
|
||||
|
||||
Reports the format of the icon.
|
||||
|
||||
@history[#:added "6.2.900.10"]}
|
||||
|
||||
|
||||
@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
|
||||
|
|
@ -50,22 +66,46 @@ Writes each icon in @racket[icos] to @racket[dest] as an
|
|||
@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?)])
|
||||
[dest path-string?])
|
||||
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).}
|
||||
executable are replaced, and only when the encoding sizes match.
|
||||
Best matches for the existing sizes and
|
||||
depth are drawn from @racket[icos] (adjusting the scale and depth of a
|
||||
best match as necessary).
|
||||
|
||||
Use @racket[replace-all-icos], instead, to replace a set of icons
|
||||
wholesale, especially when the set include PNG-format icons.}
|
||||
|
||||
|
||||
@defproc[(replace-all-icos [icos (listof ico?)]
|
||||
[dest (or/c path-string? output-port?)])
|
||||
void?]{
|
||||
|
||||
Replaces the icon set in the executable @racket[dest] with the given
|
||||
set of icons.}
|
||||
|
||||
|
||||
@defproc[(ico->argb [ico ico?]) bytes?]{
|
||||
|
||||
Converts an icon to an ARGB byte string, which has the icon's pixels
|
||||
Converts an icon in BMP format (see @racket[ico-format])
|
||||
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[(ico->png-bytes [ico ico?]) bytes?]{
|
||||
|
||||
Returns the bytes of a PNG encoding for an icon in PNG format (see
|
||||
@racket[ico-format]).
|
||||
|
||||
@history[#:added "6.2.900.10"]}
|
||||
|
||||
|
||||
@defproc[(argb->ico [width (integer-in 1 256)]
|
||||
[height (integer-in 1 256)]
|
||||
[bstr bytes?]
|
||||
|
|
@ -73,7 +113,16 @@ green, and blue channels) for each pixel.}
|
|||
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.
|
||||
@racket[ico->argb]) to an icon of the given width, height, and depth
|
||||
in BMP format.
|
||||
|
||||
The @racket[bstr] argument must have a length @racket[(* 4 width height)],
|
||||
and @racket[(* width depth)] must be a multiple of 8.}
|
||||
|
||||
|
||||
@defproc[(png-bytes->ico [bstr bytes?])
|
||||
ico?]{
|
||||
|
||||
Wraps the given PNG encoding as a PNG-encoded icon.
|
||||
|
||||
@history[#:added "6.2.900.10"]}
|
||||
|
|
|
|||
606
racket/collects/compiler/private/pe-rsrc.rkt
Normal file
606
racket/collects/compiler/private/pe-rsrc.rkt
Normal file
|
|
@ -0,0 +1,606 @@
|
|||
#lang racket/base
|
||||
(require racket/contract
|
||||
racket/pretty)
|
||||
|
||||
(provide read-pe+resources
|
||||
update-resources
|
||||
|
||||
resource-ref
|
||||
resource-ref/path
|
||||
resource-set
|
||||
resource-remove)
|
||||
|
||||
(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))
|
||||
(define (xword->integer p)
|
||||
(integer-bytes->integer (read-bytes 8 p) #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 (add-flag v)
|
||||
(bitwise-ior #x80000000 v))
|
||||
|
||||
(define-logger pe-rsrc)
|
||||
|
||||
(define (skip-to-image-headers-after-signature p)
|
||||
;; p is expected to be a file port
|
||||
(define dos-sig (word->integer p))
|
||||
(unless (= #x5A4D dos-sig)
|
||||
(error 'pe-rsrc "bad DOS signature ~x" dos-sig))
|
||||
(file-position p 60)
|
||||
(let ([pos (dword->integer p)])
|
||||
;; pos points to IMAGE_NT_HEADERS
|
||||
;; (log-error "at ~s" pos)
|
||||
(file-position p pos)
|
||||
(define sig (dword->integer p))
|
||||
(unless (= #x4550 sig) ; = #"PE\0\0"
|
||||
(error 'pe-rsrc "bad PE signature ~x" sig))
|
||||
pos))
|
||||
|
||||
(struct pe (sections section-alignment file-alignment
|
||||
image-size-pos section-start-pos rsrc-offset rsrc-virtual-addr rsrc-size))
|
||||
(struct section (name virtual-size virtual-addr
|
||||
file-length file-position
|
||||
characteristics)
|
||||
#:prefab)
|
||||
|
||||
(define (read-pe p)
|
||||
(let ([pos (skip-to-image-headers-after-signature p)])
|
||||
(word->integer p) ; skip machine
|
||||
(let ([num-sections (word->integer p)]
|
||||
[_ (begin (dword->integer p) ; date time stamp
|
||||
(dword->integer p) ; symbol table - 0 for modern exes
|
||||
(dword->integer p))] ; symbol count - 0 for modern exes
|
||||
[size (word->integer p)]) ; size of optional headers
|
||||
(file-position p (+ pos 4 20))
|
||||
(define image-type
|
||||
(case (word->integer p)
|
||||
[(#x10B) 'pe32]
|
||||
[(#x20B) 'pe32+]
|
||||
[else (error "unrecognized image type")]))
|
||||
(file-position p (+ pos 4 20 32))
|
||||
(define section-alignment (dword->integer p))
|
||||
(define file-alignment (dword->integer p))
|
||||
(log-pe-rsrc-debug "alignment ~x ~x" section-alignment file-alignment)
|
||||
(define image-size-pos (+ pos 4 20 56))
|
||||
(file-position p image-size-pos)
|
||||
(log-pe-rsrc-debug "image size ~x" (dword->integer p))
|
||||
;;(file-position p (+ pos 4 20 64))
|
||||
;;(log-error "checksum ~x at ~a" (dword->integer p) (+ pos 4 20 64))
|
||||
;;(file-position p (+ pos 4 20 (if (eq? image-type 'pe32) 92 108)))
|
||||
;;(log-error "extra entries ~a in ~a" (dword->integer p) size)
|
||||
(define rsrc-offset (+ pos 4 20 (if (eq? image-type 'pe32) 112 128)))
|
||||
(file-position p rsrc-offset)
|
||||
(define rsrc-virtual-addr (dword->integer p))
|
||||
(define rsrc-size (dword->integer p))
|
||||
(define section-start-pos (+ pos
|
||||
4 ; Signature : DWORD
|
||||
20 ; FileHeader: IMAGE_FILE_HEADER
|
||||
size)) ; "optional" header
|
||||
(define (z v) (unless (zero? v) (error "expected zero")))
|
||||
(pe (let sloop ([i 0] [section-pos section-start-pos])
|
||||
(if (= i num-sections)
|
||||
null
|
||||
(begin
|
||||
(file-position p section-pos)
|
||||
;; p points to an IMAGE_SECTION_HEADER
|
||||
(cons (section (read-bytes 8 p) ; name
|
||||
(dword->integer p) ; virtual size
|
||||
(dword->integer p) ; virtual address
|
||||
(dword->integer p) ; length
|
||||
(dword->integer p) ; file pos
|
||||
(begin
|
||||
(z (dword->integer p)) ; relocations (zero)
|
||||
(z (dword->integer p)) ; line numbers (zero)
|
||||
(z (word->integer p)) ; num relocations (zero)
|
||||
(z (word->integer p)) ; num line numbers (zero)
|
||||
(dword->integer p))) ; characteristics
|
||||
(sloop (add1 i) (+ section-pos 40))))))
|
||||
section-alignment
|
||||
file-alignment
|
||||
image-size-pos
|
||||
section-start-pos
|
||||
rsrc-offset
|
||||
rsrc-virtual-addr
|
||||
rsrc-size))))
|
||||
|
||||
(define (show-sections sections)
|
||||
(for/fold ([prev-end 0] [prev-full-end 0]) ([s (in-list sections)])
|
||||
(log-pe-rsrc-debug "~s ~x [+~x/+~x] @ ~x ~x [-> ~x] $~x"
|
||||
(section-name s)
|
||||
(section-virtual-addr s)
|
||||
(- (section-virtual-addr s) prev-end)
|
||||
(- (section-virtual-addr s) prev-full-end)
|
||||
(section-file-position s)
|
||||
(section-file-length s)
|
||||
(section-virtual-size s)
|
||||
(section-characteristics s))
|
||||
(values (+ (section-virtual-addr s)
|
||||
(section-virtual-size s))
|
||||
(+ (section-virtual-addr s)
|
||||
(section-file-length s))))
|
||||
(void))
|
||||
|
||||
(define (show-resources rsrcs [indent ""])
|
||||
(cond
|
||||
[(directory? rsrcs)
|
||||
(log-pe-rsrc-debug "~a~s" indent (entry-name rsrcs))
|
||||
(for ([e (in-list (directory-content rsrcs))])
|
||||
(show-resources e (string-append indent " ")))]
|
||||
[else
|
||||
(log-pe-rsrc-debug "~a~s ~x ~s at ~x" indent (entry-name rsrcs)
|
||||
(bytes-length (resource-content rsrcs))
|
||||
(resource-codepage rsrcs)
|
||||
(resource-file-pos rsrcs))]))
|
||||
|
||||
(struct entry (name) #:prefab)
|
||||
(struct directory entry (timestamp major-version minor-version content) #:prefab)
|
||||
(struct resource entry (content codepage file-pos) #:prefab)
|
||||
|
||||
(define (read-rsrcs p rsrc-pos rsrc-virtual-addr)
|
||||
(let loop ([dir-name #f] [dir-pos 0] [depth 0])
|
||||
(file-position p (+ rsrc-pos dir-pos 4))
|
||||
(let ([timestamp (dword->integer p)]
|
||||
[major-version (word->integer p)]
|
||||
[minor-version (word->integer p)]
|
||||
[num-named (word->integer p)]
|
||||
[num-ided (word->integer p)])
|
||||
;;(log-error "dir at ~x[~a]: ~a+~a" dir-pos depth num-named num-ided)
|
||||
(directory
|
||||
dir-name
|
||||
timestamp
|
||||
major-version
|
||||
minor-version
|
||||
(let iloop ([i 0])
|
||||
(if (= i (+ num-ided num-named))
|
||||
null
|
||||
(let ([name-delta (dword->integer p)]
|
||||
[data-delta (dword->integer p)]
|
||||
[next (file-position p)])
|
||||
(cons
|
||||
(let ([name (if (i . < . num-named)
|
||||
(begin
|
||||
;;(log-error "name at ~x = ~x" (value name-delta) (+ rsrc-pos (value name-delta)))
|
||||
(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)
|
||||
""))))
|
||||
name-delta)])
|
||||
(if (flag data-delta)
|
||||
;; Directory:
|
||||
(loop name (value data-delta) (add1 depth))
|
||||
;; Entry:
|
||||
(begin
|
||||
(file-position p (+ rsrc-pos (value data-delta)))
|
||||
(let ([rva (dword->integer p)]
|
||||
[size (dword->integer p)]
|
||||
[codepage (dword->integer p)])
|
||||
;;(log-error "resource at ~x ~x" (value data-delta) size)
|
||||
(define file-pos (+ rva
|
||||
(- rsrc-pos
|
||||
rsrc-virtual-addr)))
|
||||
(file-position p file-pos)
|
||||
(resource name
|
||||
(read-bytes size p)
|
||||
codepage
|
||||
file-pos)))))
|
||||
(begin
|
||||
(file-position p next)
|
||||
(iloop (add1 i)))))))))))
|
||||
|
||||
(define (write-rsrcs rsrcs p virtual-addr)
|
||||
(define (sorted-directory-content e)
|
||||
(sort (directory-content e)
|
||||
#:key entry-name
|
||||
(lambda (a b)
|
||||
(cond
|
||||
[(string? a)
|
||||
(if (string? a)
|
||||
(string<? a b)
|
||||
#f)]
|
||||
[(string? b) #f]
|
||||
[else
|
||||
(< a b)]))))
|
||||
;; Compute offsets ----------------------------------------
|
||||
(define (directory-size e)
|
||||
(+ 16 (* 8 (length (directory-content e)))))
|
||||
(define-values (dir-end-pos rev-entries dir-pos-ht)
|
||||
(let loop ([rsrcs rsrcs]
|
||||
[pos (directory-size rsrcs)]
|
||||
[rev-entries (list rsrcs)]
|
||||
[dir-pos-ht (hasheq)])
|
||||
(cond
|
||||
[(resource? rsrcs) (values pos (cons rsrcs rev-entries) dir-pos-ht)]
|
||||
[else
|
||||
(define content (sorted-directory-content rsrcs))
|
||||
(define-values (new-pos new-rev-entries new-dir-pos-ht)
|
||||
(let dloop ([content content]
|
||||
[pos pos]
|
||||
[rev-entries rev-entries]
|
||||
[dir-pos-ht dir-pos-ht])
|
||||
(cond
|
||||
[(null? content) (values pos rev-entries dir-pos-ht)]
|
||||
[else
|
||||
(define e (car content))
|
||||
(cond
|
||||
[(directory? e)
|
||||
(dloop (cdr content)
|
||||
(+ pos (directory-size e))
|
||||
(cons e rev-entries)
|
||||
(hash-set dir-pos-ht e pos))]
|
||||
[else
|
||||
(dloop (cdr content) pos rev-entries dir-pos-ht)])])))
|
||||
(let dloop ([content content]
|
||||
[pos new-pos]
|
||||
[rev-entries new-rev-entries]
|
||||
[dir-pos-ht new-dir-pos-ht])
|
||||
(cond
|
||||
[(null? content) (values pos rev-entries dir-pos-ht)]
|
||||
[else
|
||||
(define-values (new-pos new-rev-entries new-dir-pos-ht)
|
||||
(loop (car content) pos rev-entries dir-pos-ht))
|
||||
(dloop (cdr content) new-pos new-rev-entries new-dir-pos-ht)]))])))
|
||||
(define entries (reverse rev-entries))
|
||||
(define align-strings? #f)
|
||||
(define (str-size s)
|
||||
(let ([n (+ 2 (* 2 (string-length s)))])
|
||||
(if align-strings?
|
||||
(if (zero? (bitwise-and n 3))
|
||||
n
|
||||
(+ n (- 4 (bitwise-and n 3))))
|
||||
n)))
|
||||
(define str-length
|
||||
(for/sum ([e (in-list entries)])
|
||||
(if (string? (entry-name e))
|
||||
(str-size (entry-name e))
|
||||
0)))
|
||||
(define aligned-str-length
|
||||
(same-alignment 4 str-length))
|
||||
(define res-start dir-end-pos)
|
||||
(define res-length (* 16 (for/sum ([e (in-list entries)])
|
||||
(if (resource? e) 1 0))))
|
||||
(define str-start (+ res-start res-length))
|
||||
(define data-start (+ str-start aligned-str-length))
|
||||
(define (align-data-size s)
|
||||
(same-alignment 2 s))
|
||||
|
||||
;; Write out directory ----------------------------------------
|
||||
(for/fold ([str-pos str-start] [res-pos res-start]) ([e (in-list entries)])
|
||||
(cond
|
||||
[(resource? e) (values str-pos res-pos)]
|
||||
[(directory? e)
|
||||
(define content (sorted-directory-content e))
|
||||
(integer->dword 0 p)
|
||||
(integer->dword (directory-timestamp e) p)
|
||||
(integer->word (directory-major-version e) p)
|
||||
(integer->word (directory-minor-version e) p)
|
||||
(define num-strs (let loop ([cs content])
|
||||
(cond
|
||||
[(null? cs) 0]
|
||||
[(number? (entry-name (car cs))) 0]
|
||||
[else (+ 1 (loop (cdr cs)))])))
|
||||
(integer->word num-strs p)
|
||||
(integer->word (- (length content) num-strs) p)
|
||||
(for/fold ([str-pos str-pos] [res-pos res-pos]) ([e (in-list content)])
|
||||
(values (cond
|
||||
[(string? (entry-name e))
|
||||
(integer->dword (add-flag str-pos) p)
|
||||
(+ str-pos (str-size (entry-name e)))]
|
||||
[else
|
||||
(integer->dword (entry-name e) p)
|
||||
str-pos])
|
||||
(cond
|
||||
[(resource? e)
|
||||
(integer->dword res-pos p)
|
||||
(+ res-pos 16)]
|
||||
[else
|
||||
(integer->dword (add-flag (hash-ref dir-pos-ht e)) p)
|
||||
res-pos])))]))
|
||||
|
||||
;; Write out resource data entries
|
||||
(for/fold ([data-pos data-start]) ([e (in-list entries)])
|
||||
(cond
|
||||
[(resource? e)
|
||||
(define len (align-data-size (bytes-length (resource-content e))))
|
||||
(integer->dword (+ data-pos virtual-addr) p)
|
||||
(integer->dword len p)
|
||||
(integer->dword (resource-codepage e) p)
|
||||
(integer->dword 0 p)
|
||||
(+ data-pos len)]
|
||||
[else
|
||||
data-pos]))
|
||||
|
||||
;; Write out strings
|
||||
(for ([e (in-list entries)])
|
||||
(define n (entry-name e))
|
||||
(when (string? n)
|
||||
(integer->word (string-length n) p)
|
||||
(for ([c (in-string n)])
|
||||
(integer->word (char->integer c) p))
|
||||
(when align-strings?
|
||||
(when (even? (string-length n))
|
||||
(integer->word 0 p)))))
|
||||
(write-bytes (make-bytes (- aligned-str-length str-length)) p)
|
||||
|
||||
;; Write out resource content
|
||||
(for ([e (in-list entries)])
|
||||
(when (resource? e)
|
||||
(define bstr (resource-content e))
|
||||
(write-bytes bstr p)
|
||||
(define aligned-size (align-data-size (bytes-length bstr)))
|
||||
(write-bytes (make-bytes (- aligned-size (bytes-length bstr))) p)))
|
||||
|
||||
(void))
|
||||
|
||||
|
||||
(define (find-section sections find-name)
|
||||
(let loop ([sections sections])
|
||||
(cond
|
||||
[(null? sections)
|
||||
(error 'find-section "can't find section: ~e" find-name)]
|
||||
[else
|
||||
(define s (car sections))
|
||||
(if (bytes=? find-name (section-name s))
|
||||
s
|
||||
(loop (cdr sections)))])))
|
||||
|
||||
(define rsrc-section-name #".rsrc\0\0\0")
|
||||
|
||||
(define (read-pe+resources i)
|
||||
(define pe (read-pe i))
|
||||
(define s (find-section (pe-sections pe) rsrc-section-name))
|
||||
|
||||
(log-pe-rsrc-debug "sections at ~x" (pe-section-start-pos pe))
|
||||
(show-sections (pe-sections pe))
|
||||
(log-pe-rsrc-debug "rsrc at ~x ~x" (pe-rsrc-virtual-addr pe) (pe-rsrc-size pe))
|
||||
|
||||
(unless (and (= (section-virtual-addr s) (pe-rsrc-virtual-addr pe))
|
||||
(>= (section-virtual-size s) (pe-rsrc-size pe)))
|
||||
(error 'pe-rsrc
|
||||
"sections and resource information do not line up in the typical way"))
|
||||
|
||||
(define rsrcs (read-rsrcs i (section-file-position s) (section-virtual-addr s)))
|
||||
|
||||
(show-resources rsrcs)
|
||||
|
||||
(values pe rsrcs))
|
||||
|
||||
(define (same-alignment orig new)
|
||||
(cond
|
||||
[(bitwise-bit-set? orig 1)
|
||||
new]
|
||||
[(bitwise-bit-set? new 1)
|
||||
(same-alignment orig (add1 new))]
|
||||
[else
|
||||
(arithmetic-shift (same-alignment
|
||||
(arithmetic-shift orig -1)
|
||||
(arithmetic-shift new -1))
|
||||
1)]))
|
||||
|
||||
(define (update-sections pe new-sections o)
|
||||
(file-position o (pe-section-start-pos pe))
|
||||
(for ([s (in-list new-sections)])
|
||||
(write-bytes (section-name s) o)
|
||||
(integer->dword (section-virtual-size s) o)
|
||||
(integer->dword (section-virtual-addr s) o)
|
||||
(integer->dword (section-file-length s) o)
|
||||
(integer->dword (section-file-position s) o)
|
||||
(integer->dword 0 o)
|
||||
(integer->dword 0 o)
|
||||
(integer->word 0 o)
|
||||
(integer->word 0 o)
|
||||
(integer->dword (section-characteristics s) o)))
|
||||
|
||||
(define (update-resources src pe rsrcs)
|
||||
(define o (open-output-bytes))
|
||||
(write-rsrcs rsrcs o (pe-rsrc-virtual-addr pe))
|
||||
(define bstr (get-output-bytes o))
|
||||
(define len (bytes-length bstr))
|
||||
|
||||
(define s (find-section (pe-sections pe) rsrc-section-name))
|
||||
(cond
|
||||
[(len . <= . (section-file-length s))
|
||||
(log-pe-rsrc-debug "new content fits in place of old content")
|
||||
(call-with-output-file
|
||||
src
|
||||
#:exists 'update
|
||||
(lambda (o)
|
||||
(file-position o (section-file-position s))
|
||||
(write-bytes bstr o)
|
||||
(write-bytes (make-bytes (- (section-file-length s) len)) o)
|
||||
|
||||
(file-position o (pe-rsrc-offset pe))
|
||||
(integer->dword (pe-rsrc-virtual-addr pe) o)
|
||||
(integer->dword len o)))]
|
||||
[else
|
||||
(log-pe-rsrc-debug "moving resources to end")
|
||||
(define new-virtual-addr
|
||||
(same-alignment
|
||||
(section-virtual-addr s)
|
||||
(for/fold ([pos 0]) ([s2 (in-list (pe-sections pe))]
|
||||
#:unless (eq? s s2))
|
||||
(max pos
|
||||
(+ (section-virtual-addr s2)
|
||||
(section-virtual-size s2))))))
|
||||
|
||||
(define o (open-output-bytes))
|
||||
(write-rsrcs rsrcs o new-virtual-addr)
|
||||
(define bstr (get-output-bytes o))
|
||||
(define len (bytes-length bstr))
|
||||
|
||||
(define new-virtual-size len)
|
||||
(define new-file-size (same-alignment (pe-section-alignment pe) len))
|
||||
(define new-position
|
||||
(let ([fs (file-size src)])
|
||||
(cond
|
||||
[(= fs (+ (section-file-position s)
|
||||
(section-file-length s)))
|
||||
;; Section was already at end, so overwrite is ok
|
||||
(section-file-position s)]
|
||||
[else
|
||||
(same-alignment (pe-file-alignment pe) fs)])))
|
||||
(log-pe-rsrc-debug "moving to ~x ~x at ~x"
|
||||
new-virtual-addr
|
||||
new-virtual-size
|
||||
new-position)
|
||||
|
||||
(define new-sections
|
||||
(sort (for/list ([s2 (in-list (pe-sections pe))])
|
||||
(if (eq? s s2)
|
||||
(section (section-name s)
|
||||
new-virtual-size new-virtual-addr
|
||||
new-file-size new-position
|
||||
(section-characteristics s))
|
||||
s2))
|
||||
<
|
||||
#:key section-virtual-addr))
|
||||
|
||||
(call-with-output-file
|
||||
src
|
||||
#:exists 'update
|
||||
(lambda (o)
|
||||
(define exe-size (+ new-position new-file-size))
|
||||
|
||||
(update-sections pe new-sections o)
|
||||
|
||||
(file-position o new-position)
|
||||
(write-bytes bstr o)
|
||||
(write-bytes (make-bytes (- new-file-size len)) o)
|
||||
|
||||
(file-position o (pe-rsrc-offset pe))
|
||||
(integer->dword new-virtual-addr o)
|
||||
(integer->dword new-virtual-size o)
|
||||
|
||||
(file-position o (pe-image-size-pos pe))
|
||||
(integer->dword (+ new-virtual-addr new-file-size) o)
|
||||
|
||||
(file-truncate o exe-size)))]))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
(define (get-match dir n)
|
||||
(and dir
|
||||
(for/or ([e (in-list (directory-content dir))])
|
||||
(and (or (not n)
|
||||
(equal? n (entry-name e)))
|
||||
e))))
|
||||
|
||||
(define (set-match dir v
|
||||
#:name [name (entry-name v)]
|
||||
#:can-remove? [can-remove? #f])
|
||||
(define new-content
|
||||
(let loop ([c (directory-content dir)])
|
||||
(cond
|
||||
[(null? c) (if v
|
||||
(list v)
|
||||
null)]
|
||||
[(or (not name)
|
||||
(equal? (entry-name (car c)) name))
|
||||
(if v
|
||||
(cons v (cdr c))
|
||||
(cdr c))]
|
||||
[else (cons (car c) (loop (cdr c)))])))
|
||||
(if (and can-remove? (null? new-content))
|
||||
#f
|
||||
(struct-copy directory dir
|
||||
[content new-content])))
|
||||
|
||||
(define (resource-ref/path rsrcs type name language)
|
||||
(define t (get-match rsrcs type))
|
||||
(define n (get-match t name))
|
||||
(define r (get-match n language))
|
||||
(values (and t (entry-name t))
|
||||
(and n (entry-name n))
|
||||
(and r (entry-name r))
|
||||
(and r (resource-content r))
|
||||
(and r (resource-file-pos r))))
|
||||
|
||||
(define (resource-ref rsrcs type name language)
|
||||
(define-values (t n l v p) (resource-ref/path rsrcs type name language))
|
||||
v)
|
||||
|
||||
(define (resource-set rsrcs type name language v)
|
||||
(define (mk name what)
|
||||
(directory (or name
|
||||
(error 'resource-set
|
||||
"cannot infer ~a"
|
||||
what))
|
||||
0 ; timestamp
|
||||
0 ; major-version
|
||||
0 ; minor-version
|
||||
null))
|
||||
(define t (or (get-match rsrcs type) (mk type 'type)))
|
||||
(define n (or (get-match t name) (mk name 'name)))
|
||||
(define l (get-match n language))
|
||||
(set-match rsrcs #:name type
|
||||
(set-match t
|
||||
#:name name
|
||||
(set-match n
|
||||
#:name language
|
||||
(resource (or language
|
||||
(and l (entry-name l))
|
||||
(error 'resource-set
|
||||
"cannot infer language"))
|
||||
v
|
||||
1252
|
||||
0)))))
|
||||
|
||||
(define (resource-remove rsrcs type name language)
|
||||
(define t (get-match rsrcs type))
|
||||
(define n (get-match t name))
|
||||
(if (get-match n language)
|
||||
(set-match rsrcs #:name type
|
||||
(set-match t
|
||||
#:name name
|
||||
#:can-remove? #t
|
||||
(set-match n
|
||||
#:name language
|
||||
#:can-remove? #t
|
||||
#f)))
|
||||
rsrcs))
|
||||
|
||||
#;
|
||||
(module+ test
|
||||
(define-syntax-rule (check a b ...)
|
||||
(let ([got (call-with-values (lambda () a) list)]
|
||||
[expect (list b ...)])
|
||||
(unless (equal? got expect)
|
||||
(error 'test "failed: ~.s\n got: ~e" 'a got))))
|
||||
(define (d name l)
|
||||
(directory name 0 0 0 l))
|
||||
(check (resource-ref (d #f null) #f #f #f)
|
||||
#f)
|
||||
(define hi-d (d #f (list (d 1 (list (d "hi" (list (resource 1033 #"ok" 1252 0))))))))
|
||||
(define hi2-d (d #f (list (d 1 (list (d "hi" (list (resource 1033 #"yep" 1252 0))))))))
|
||||
(check (resource-set (d #f null) 1 "hi" 1033 #"ok")
|
||||
hi-d)
|
||||
(check (resource-remove hi-d #f "no-hi" #f)
|
||||
hi-d)
|
||||
(check (resource-remove hi-d #f "hi" #f)
|
||||
(d #f null))
|
||||
(check (resource-set hi-d #f "hi" #f #"yep")
|
||||
hi2-d)
|
||||
(define bye-d (d #f (list (d 1 (list (d "hi" (list (resource 1033 #"ok" 1252 0)))
|
||||
(d "bye" (list (resource 1033 #"ok" 1252 0))))))))
|
||||
(check (resource-set hi-d 1 "bye" 1033 #"ok")
|
||||
bye-d)
|
||||
(check (resource-remove bye-d 1 "bye" #f)
|
||||
hi-d))
|
||||
|
||||
|
|
@ -1,11 +1,13 @@
|
|||
#lang racket/base
|
||||
(require racket/contract)
|
||||
(require racket/contract
|
||||
compiler/private/pe-rsrc)
|
||||
|
||||
(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))]
|
||||
[ico-width (ico? . -> . exact-positive-integer?)]
|
||||
[ico-height (ico? . -> . exact-positive-integer?)]
|
||||
[ico-depth (ico? . -> . (or/c 1 2 4 8 16 24 32))]
|
||||
[ico-format (ico? . -> . (or/c 'bmp 'png))]
|
||||
|
||||
[read-icos ((or/c path-string? input-port?) . -> . (listof ico?))]
|
||||
[read-icos-from-exe ((or/c path-string? input-port?) . -> . (listof ico?))]
|
||||
|
|
@ -16,14 +18,19 @@
|
|||
'must-truncate 'truncate/replace)]
|
||||
. ->* .
|
||||
void?)]
|
||||
[replace-icos ((listof ico?) (or/c path-string? output-port?)
|
||||
. -> . void?)]
|
||||
[replace-icos ((listof ico?) path-string? . -> . void?)]
|
||||
[replace-all-icos ((listof ico?) path-string? . -> . void?)]
|
||||
|
||||
[ico->argb (ico? . -> . bytes?)]
|
||||
[ico->png-bytes (ico? . -> . bytes?)]
|
||||
[argb->ico ([(integer-in 1 256) (integer-in 1 256) bytes? ]
|
||||
[#:depth (one-of/c 1 2 4 8 24 32)]
|
||||
. ->* .
|
||||
ico?)]))
|
||||
ico?)]
|
||||
[png-bytes->ico ([bytes?]
|
||||
[]
|
||||
. ->* .
|
||||
ico?)]))
|
||||
|
||||
;; parse-ico build-ico
|
||||
|
||||
|
|
@ -46,107 +53,21 @@
|
|||
(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
|
||||
(if (eq? (ico-format i) 'bmp)
|
||||
256
|
||||
(ico-png-width i))
|
||||
v)))
|
||||
(define (ico-height i) (let ([v (cadr (ico-desc i))])
|
||||
(if (= v 0)
|
||||
256
|
||||
(if (eq? (ico-format i) 'bmp)
|
||||
256
|
||||
(ico-png-height i))
|
||||
v)))
|
||||
(define (ico-depth i)
|
||||
(let ([cols (caddr (ico-desc i))])
|
||||
|
|
@ -155,6 +76,26 @@
|
|||
(integer-length (sub1 cols)))))
|
||||
(define (ico-colors i) (num-colors (ico-desc i)))
|
||||
|
||||
(define (ico-format i)
|
||||
(define bstr (cdr (ico-data i)))
|
||||
(define tag (subbytes bstr 0 2))
|
||||
(cond
|
||||
[(and ((bytes-length bstr) . > . 4)
|
||||
(equal? (subbytes bstr 0 4) #"\211PNG"))
|
||||
'png]
|
||||
[else
|
||||
;; Asume BMP
|
||||
'bmp]))
|
||||
|
||||
(define (ico-png-width i)
|
||||
(png-width (cdr (ico-data i))))
|
||||
(define (png-width bstr)
|
||||
(integer-bytes->integer (subbytes bstr 16 20) #f #t))
|
||||
(define (ico-png-height i)
|
||||
(png-height (cdr (ico-data i))))
|
||||
(define (png-height bstr)
|
||||
(integer-bytes->integer (subbytes bstr 20 24) #f #t))
|
||||
|
||||
(define (num-colors l)
|
||||
(let ([n (caddr l)])
|
||||
(if (zero? n)
|
||||
|
|
@ -173,8 +114,8 @@
|
|||
(ormap (lambda (ico-ico)
|
||||
(let ([le (ico-desc exe-ico)]
|
||||
[li (ico-desc ico-ico)])
|
||||
(and (= (car li) (car le))
|
||||
(= (cadr li) (cadr le))
|
||||
(and (= (ico-width exe-ico) (ico-width ico-ico))
|
||||
(= (ico-height exe-ico) (ico-height ico-ico))
|
||||
(= (num-colors li) (num-colors le))
|
||||
(= (bytes-length (cdr (ico-data exe-ico)))
|
||||
(bytes-length (cdr (ico-data ico-ico))))
|
||||
|
|
@ -185,8 +126,8 @@
|
|||
;; need a 16x16, 32x32, or 48x48
|
||||
;; ico
|
||||
(and
|
||||
(= (car (ico-desc exe-ico))
|
||||
(cadr (ico-desc exe-ico)))
|
||||
(= (ico-width exe-ico)
|
||||
(ico-height exe-ico))
|
||||
(memq (car (ico-desc exe-ico))
|
||||
'(16 32 48))
|
||||
(let ([biggest-colorest #f])
|
||||
|
|
@ -249,16 +190,88 @@
|
|||
#t)))))))))])
|
||||
(unless ico-ico (log-error "no icon conversion available to ~a" (ico-desc exe-ico)))
|
||||
(when ico-ico
|
||||
(file-position p (car (ico-data exe-ico)))
|
||||
(file-position p (let ([d (car (ico-data exe-ico))])
|
||||
(if (vector? d)
|
||||
(vector-ref d 0)
|
||||
d)))
|
||||
(display (cdr (ico-data ico-ico)) p)))))
|
||||
exe-icos))
|
||||
(lambda () (close-output-port p))))))
|
||||
|
||||
(define (replace-all-icos ico-list exe-file)
|
||||
(define-values (pe rsrcs)
|
||||
(call-with-input-file*
|
||||
exe-file
|
||||
read-pe+resources))
|
||||
(define-values (type name language icos file-pos)
|
||||
(resource-ref/path rsrcs 14 #f #f))
|
||||
(define old-icos
|
||||
(if icos
|
||||
(get-icos (open-input-bytes icos) rsrcs)
|
||||
null))
|
||||
(define (ico-res-type i) (vector-ref (car (ico-data i)) 1))
|
||||
(define (ico-res-name i) (vector-ref (car (ico-data i)) 2))
|
||||
(define (ico-res-language i) (vector-ref (car (ico-data i)) 3))
|
||||
(define cleaned-rsrcs
|
||||
(for/fold ([rsrcs rsrcs]) ([old-i (in-list old-icos)])
|
||||
(resource-remove rsrcs
|
||||
(ico-res-type old-i)
|
||||
(ico-res-name old-i)
|
||||
(ico-res-language old-i))))
|
||||
;; Replace individual icons where size and depth match
|
||||
(define-values (new-rsrcs named-icos)
|
||||
(for/fold ([rsrcs cleaned-rsrcs] [named-icos null]) ([i (in-list ico-list)])
|
||||
(define old-i (for/or ([old-i (in-list old-icos)])
|
||||
(and (= (ico-width i) (ico-width old-i))
|
||||
(= (ico-height i) (ico-height old-i))
|
||||
(= (ico-depth i) (ico-depth old-i))
|
||||
old-i)))
|
||||
(define name
|
||||
(cond
|
||||
[old-i (ico-res-name old-i)]
|
||||
[else
|
||||
;; Generate next unused id:
|
||||
(let loop ([id 1])
|
||||
(if (resource-ref rsrcs 3 id 1033)
|
||||
(loop (add1 id))
|
||||
id))]))
|
||||
(values (resource-set rsrcs
|
||||
3
|
||||
name
|
||||
1033
|
||||
(cdr (ico-data i)))
|
||||
(cons (ico (ico-desc i)
|
||||
(cons (vector #f 4 name 1033)
|
||||
(cdr (ico-data i))))
|
||||
named-icos))))
|
||||
;; Update ico:
|
||||
(define ready-rsrcs
|
||||
(resource-set new-rsrcs type name language (make-icos-header named-icos)))
|
||||
;; Write new resources:
|
||||
(update-resources exe-file pe ready-rsrcs))
|
||||
|
||||
(define (make-icos-header icos)
|
||||
(define o (open-output-bytes))
|
||||
(integer->word 0 o)
|
||||
(integer->word 1 o)
|
||||
(integer->word (length icos) o)
|
||||
(for ([i (in-list icos)])
|
||||
(define desc (ico-desc i))
|
||||
(write-byte (list-ref desc 0) o)
|
||||
(write-byte (list-ref desc 1) o)
|
||||
(write-byte (list-ref desc 2) o)
|
||||
(write-byte (list-ref desc 3) o)
|
||||
(integer->word (list-ref desc 4) o)
|
||||
(integer->word (list-ref desc 5) o)
|
||||
(integer->dword (bytes-length (cdr (ico-data i))) o)
|
||||
(integer->word (vector-ref (car (ico-data i)) 2) o))
|
||||
(get-output-bytes o))
|
||||
|
||||
;; ------------------------------
|
||||
;; Image parsing
|
||||
;; ------------------------------
|
||||
|
||||
(define (get-icos file res?)
|
||||
(define (get-icos file rsrcs)
|
||||
(let ([p (if (input-port? file)
|
||||
file
|
||||
(open-input-file file))])
|
||||
|
|
@ -282,7 +295,7 @@
|
|||
(word->integer p) ; planes
|
||||
(word->integer p)) ; bitcount
|
||||
(list (dword->integer p) ; bytes
|
||||
((if res? ; where or icon id
|
||||
((if rsrcs ; where or icon id
|
||||
word->integer
|
||||
dword->integer)
|
||||
p)))
|
||||
|
|
@ -293,14 +306,16 @@
|
|||
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)))))
|
||||
(cond
|
||||
[rsrcs
|
||||
(define-values (type name lang bstr file-pos)
|
||||
(resource-ref/path rsrcs 3 where #f))
|
||||
(cons (vector file-pos type name lang)
|
||||
bstr)]
|
||||
[else
|
||||
(file-position p where)
|
||||
(cons where
|
||||
(read-bytes size p))])))
|
||||
;; If colors, planes, and bitcount are all 0,
|
||||
;; get the info from the DIB data
|
||||
(let ([desc (ico-desc ico)])
|
||||
|
|
@ -595,6 +610,8 @@
|
|||
(cadr image)))) ; list of mask pixels
|
||||
|
||||
(define (ico->argb ico)
|
||||
(unless (eq? 'bmp (ico-format ico))
|
||||
(error 'ico->argb "icon not in BMP format"))
|
||||
(let* ([image (parse-ico ico)]
|
||||
[pixels (list-ref image 3)]
|
||||
[len (length pixels)]
|
||||
|
|
@ -616,6 +633,11 @@
|
|||
(bytes-set! bstr (+ 3 (* i 4)) (bitwise-and #xff p))))
|
||||
bstr))
|
||||
|
||||
(define (ico->png-bytes ico)
|
||||
(unless (eq? 'png (ico-format ico))
|
||||
(error 'ico->argb "icon not in PNG format"))
|
||||
(cdr (ico-data ico)))
|
||||
|
||||
(define (build-ico base-ico image mask check?)
|
||||
(make-ico (ico-desc base-ico)
|
||||
(cons (car (ico-data base-ico))
|
||||
|
|
@ -625,14 +647,12 @@
|
|||
(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-values (pe rsrcs)
|
||||
(call-with-input-file*
|
||||
exe-file
|
||||
read-pe+resources))
|
||||
(define icos (resource-ref rsrcs 14 #f #f))
|
||||
(get-icos (open-input-bytes icos) rsrcs))
|
||||
|
||||
(define (write-header w h depth o)
|
||||
(integer->dword 40 o) ; size
|
||||
|
|
@ -647,6 +667,11 @@
|
|||
(integer->dword 0 o) ; used
|
||||
(integer->dword 0 o)) ; important
|
||||
|
||||
(define (png-bytes->ico bstr)
|
||||
(define (256+->0 v) (if (v . >= . 256) 0 v))
|
||||
(ico (list (256+->0 (png-width bstr)) (256+->0 (png-height bstr)) 0 0 1 32)
|
||||
(cons #f bstr)))
|
||||
|
||||
(define (argb->ico w h argb #:depth [depth 32])
|
||||
(let ([o (open-output-bytes)])
|
||||
(write-header w h 32 o)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user