suzanne.soy/gui
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

adjust include-bitmap so that it does not write to the filesystem

Browse Source 
(also, Rackety)

original commit: 913883fd282fb767a3db6d9f22797eb6194da60a
This commit is contained in:
Robby Findler 2011-08-26 08:11:58 -05:00
parent 71f4c0632c
commit a106a0e769
1 changed files with 61 additions and 62 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

123
collects/mrlib/include-bitmap.rkt
View File

@ -1,68 +1,67 @@
(module include-bitmap mzscheme
(require mred
mzlib/class
mzlib/file
setup/main-collects)
(require-for-syntax syntax/path-spec
compiler/cm-accomplice
setup/main-collects)
#lang racket/base
(require racket/gui/base
racket/class
racket/file
setup/main-collects)
(require (for-syntax racket/base
syntax/path-spec
compiler/cm-accomplice
setup/main-collects))
(provide include-bitmap
include-bitmap/relative-to)
(define-syntax (-include-bitmap stx)
(syntax-case stx ()
[(_ orig-stx source path-spec type)
(let* ([c-file (resolve-path-spec #'path-spec #'source #'orig-stx)]
[content
(with-handlers ([exn:fail?
(lambda (exn)
(error 'include-bitmap
"could not load ~e: ~a"
c-file
(if (exn? exn)
(exn-message exn)
(format "~e" exn))))])
(with-input-from-file c-file
(lambda ()
(read-bytes (file-size c-file)))))])
(register-external-file c-file)
(with-syntax ([content content]
[c-file (path->main-collects-relative c-file)])
(syntax/loc stx
(get-or-load-bitmap content 'c-file type))))]))
(provide include-bitmap
include-bitmap/relative-to)
(define-syntax (include-bitmap/relative-to stx)
(syntax-case stx ()
[(_ source path-spec) #`(-include-bitmap #,stx source path-spec 'unknown/mask)]
[(_ source path-spec type) #`(-include-bitmap #,stx source path-spec type)]))
(define-syntax (-include-bitmap stx)
(syntax-case stx ()
[(_ orig-stx source path-spec type)
(let* ([c-file (resolve-path-spec #'path-spec #'source #'orig-stx)]
[content
(with-handlers ([exn:fail?
(lambda (exn)
(error 'include-bitmap
"could not load ~e: ~a"
c-file
(if (exn? exn)
(exn-message exn)
(format "~e" exn))))])
(with-input-from-file c-file
(lambda ()
(read-bytes (file-size c-file)))))])
(register-external-file c-file)
(with-syntax ([content content]
[c-file (path->main-collects-relative c-file)])
(syntax/loc stx
(get-or-load-bitmap content 'c-file type))))]))
(define-syntax (include-bitmap stx)
(syntax-case stx ()
[(_ path-spec) #`(-include-bitmap #,stx #,stx path-spec 'unknown/mask)]
[(_ path-spec type) #`(-include-bitmap #,stx #,stx path-spec type)]))
(define-syntax (include-bitmap/relative-to stx)
(syntax-case stx ()
[(_ source path-spec) #`(-include-bitmap #,stx source path-spec 'unknown/mask)]
[(_ source path-spec type) #`(-include-bitmap #,stx source path-spec type)]))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Run-time support
(define-syntax (include-bitmap stx)
(syntax-case stx ()
[(_ path-spec) #`(-include-bitmap #,stx #,stx path-spec 'unknown/mask)]
[(_ path-spec type) #`(-include-bitmap #,stx #,stx path-spec type)]))
(define cached (make-hash-table 'equal))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Run-time support
(define (get-or-load-bitmap content orig type)
(hash-table-get cached (cons content type)
(lambda ()
(let ([bm (let ([fn (make-temporary-file)])
(dynamic-wind
void
(lambda ()
(with-output-to-file fn
(lambda () (display content))
'truncate)
(make-object bitmap% fn type))
(lambda ()
(delete-file fn))))])
(unless (send bm ok?)
(error 'include-bitmap
"unable to parse image, originated from: ~a"
(path->string (main-collects-relative->path orig))))
(hash-table-put! cached (cons content type) bm)
bm)))))
(define cached (make-hash))
(define (get-or-load-bitmap content orig type)
(hash-ref cached
(cons content type)
(λ ()
(define-values (in out) (make-pipe))
(thread
(λ ()
(display content out)
(close-output-port out)))
(define bm (make-object bitmap% in type))
(unless (send bm ok?)
(error 'include-bitmap
"unable to parse image, originated from: ~a"
(path->string (main-collects-relative->path orig))))
(hash-set! cached (cons content type) bm)
bm)))