[racket-dev] Feature request: allow 2htdp/image bitmap function to load from URL

Eventually we hope to add a 'url'-form to require, at which point it
will make a lot of sense to support that it bitmap. In the meantime, I
think the best thing is probably to make a new form, say bitmap-url,
and put it into a separate teachpack.

Robby

On Sunday, June 13, 2010, Nadeem Abdul Hamid <nadeem at acm.org> wrote:
> Below is a quick hack I did to allow loading a 2htdp/image bitmap from a url like this:
>
>     (bitmap (url "http://docs.racket-lang.org/teachpack/4e85791a5.png"))
>
> There's no error checking, and I was too lazy to do a diff, but I've marked the three pieces that I added with "; .nah." comments. Would it be possible to add this feature to the library? This would have been a little easier maybe if bitmap% provided load from ports, but I see that's an open PR (9335).
>
> Thanks,
> --- nadeem
>
>
> (define-syntax (bitmap stx)
>   (syntax-case stx ()
>     [(_ arg)
>      (let* ([arg (syntax->datum #'arg)]
>             [url? (and (pair? arg) (eq? (car arg) 'url))]   ; .nah.
>             [path
>              (cond
>                [(and (pair? arg)
>                      (eq? (car arg) 'planet))
>                 (raise-syntax-error 'bitmap "planet paths not yet supported" stx)]
>                ; .nah. ...
>                [url?
>                 (let ([temp-path (make-temporary-file)])
>                   (call-with-output-file temp-path
>                     (lambda (outp)
>                       (call/input-url
>                        (string->url (cadr arg)) get-pure-port
>                        (lambda (inp)
>                          (copy-port inp outp)
>                             )))
>                     #:exists 'replace
>                     )
>                   (display temp-path)
>                   temp-path
>                   )]
>                ; ... .nah.
>                [(symbol? arg)
>                 (let ([pieces (regexp-split #rx"/" (symbol->string arg))])
>                   (cond
>                     [(null? pieces)
>                      (raise-syntax-error 'bitmap "expected a path with a / in it" stx)]
>                     [else
>                      (let loop ([cps (current-library-collection-paths)])
>                        (cond
>                          [(null? cps)
>                           (raise-syntax-error 'bitmap
>                                               (format "could not find the ~a collection" (car pieces))
>                                               stx)]
>                          [else
>                           (if (and (directory-exists? (car cps))
>                                    (member (build-path (car pieces))
>                                            (directory-list (car cps))))
>                               (let ([candidate (apply build-path (car cps) pieces)])
>                                 (if (file-exists? candidate)
>                                     candidate
>                                     (raise-syntax-error 'bitmap
>                                                         (format "could not find ~a in the ~a collection"
>                                                                 (apply string-append (add-between (cdr pieces) "/"))
>                                                                 (car pieces))
>                                                         stx)))
>                               (loop (cdr cps)))]))]))]
>                [(string? arg)
>                 (path->complete-path
>                  arg
>                  (or (current-load-relative-directory)
>                      (current-directory)))])]
>             )
>        ; .nah. ...
>        #`(let ([result (make-object image-snip% (make-object bitmap% #,path 'unknown/mask))])
>            (when #,url? (delete-file #,path))
>            result)
>        ; ... .nah.
>        )]))
> _________________________________________________
>   For list-related administrative tasks:
>   http://lists.racket-lang.org/listinfo/dev
>