From a106a0e769827277f79b0c40a78ca626f5d1cff6 Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Fri, 26 Aug 2011 08:11:58 -0500
Subject: [PATCH] adjust include-bitmap so that it does not write to the
 filesystem   (also, Rackety)

original commit: 913883fd282fb767a3db6d9f22797eb6194da60a
---
 collects/mrlib/include-bitmap.rkt | 123 +++++++++++++++---------------
 1 file changed, 61 insertions(+), 62 deletions(-)

diff --git a/collects/mrlib/include-bitmap.rkt b/collects/mrlib/include-bitmap.rkt
index 532ba844..4ad4f27f 100644
--- a/collects/mrlib/include-bitmap.rkt
+++ b/collects/mrlib/include-bitmap.rkt
@@ -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)))