diff --git a/pitfall/pitfall/jpeg.rkt b/pitfall/pitfall/jpeg.rkt index dbe328cf..1acd899e 100644 --- a/pitfall/pitfall/jpeg.rkt +++ b/pitfall/pitfall/jpeg.rkt @@ -1,80 +1,71 @@ #lang debug racket/base (require racket/class - "reference.rkt" - racket/contract + racket/match + "reference.rkt" racket/dict - sugar/unstable/class - sugar/unstable/js - sugar/unstable/dict - sugar/unstable/port) + sugar/unstable/dict) (provide JPEG) -(define MARKERS '(#xffc0 #xffc1 #xffc2 #xffc3 #xffc5 #xffc6 #xffc7 - #xffc8 #xffc9 #xffca #xffcb #xffcc #xffcd #xffce #xffcf)) +(define MARKERS '(#xffc0 #xffc1 #xffc2 #xffc3 + #xffc5 #xffc6 #xffc7 + #xffc8 #xffc9 #xffca #xffcb + #xffcc #xffcd #xffce #xffcf)) -(define-subclass object% (JPEG data [label #f]) - (define last-ip (current-input-port)) - (current-input-port (if (input-port? data) data (open-input-bytes data))) - (unless (equal? (read-16bit-integer) #xffd8) - (error 'JPEG "Start of Input marker byte not found")) - - (define marker (let loop ([skip 0]) - (read-bytes skip) - (define m (read-16bit-integer)) - (if (memv m MARKERS) - m - (loop (read-16bit-integer (peek-bytes 2 0)))))) - - (read-16bit-integer) - (field [bits (read-byte)] - [height (read-16bit-integer)] - [width (read-16bit-integer)] - [channels (read-byte)] - [colorSpace (case channels - [(1) "DeviceGray"] - [(3) "DeviceRGB"] - [(4) "DeviceCMYK"])] - [obj #f]) - - (current-input-port last-ip) +(define JPEG + (class object% + (super-new) + (init-field [(@data data)] [(@label label) #f]) + + (define jpeg-ip (if (input-port? @data) @data (open-input-bytes @data))) + (unless (= (read-16bit-integer jpeg-ip) #xffd8) + (error 'JPEG "Start of input marker byte not found")) + (define marker (let loop ([skip 0]) + (read-bytes skip jpeg-ip) + (define m (read-16bit-integer jpeg-ip)) + (if (memv m MARKERS) + m + (loop (read-16bit-integer (peek-bytes 2 0 jpeg-ip)))))) + (read-16bit-integer jpeg-ip) + (field [(@bits bits) (read-byte jpeg-ip)] + [(@height height) (read-16bit-integer jpeg-ip)] + [(@width width) (read-16bit-integer jpeg-ip)] + [(@channels channels) (read-byte jpeg-ip)] + [(@colorSpace colorSpace) (case @channels + [(1) "DeviceGray"] + [(3) "DeviceRGB"] + [(4) "DeviceCMYK"])] + [(@obj obj) #f]) - (as-methods - embed)) + (define/public (embed) + (unless @obj + (set! @obj (make-ref + (mhash + 'Type "XObject" + 'Subtype "Image" + 'BitsPerComponent @bits + 'Width @width + 'Height @height + 'ColorSpace @colorSpace + 'Filter "DCTDecode"))) + + ;; add extra decode params for CMYK images. By swapping the + ;; min and max values from the default, we invert the colors. See + ;; section 4.8.4 of the spec. + (when (equal? @colorSpace "DeviceCMYK") + (dict-set! @obj 'Decode '(1.0 0.0 1.0 0.0 1.0 0.0 1.0 0.0))) + (file-position @data 0) + (send* @obj [write @data] + [end]))))) -(define (read-16bit-integer [bytes-or-port #f]) +(define (read-16bit-integer ip-or-bytes) (define signed #f) (define big-endian #t) - (integer-bytes->integer - (read-bytes 2 (cond - [(bytes? bytes-or-port) (open-input-bytes bytes-or-port)] - [(port? bytes-or-port) bytes-or-port] - [else (current-input-port)])) signed big-endian)) - -(define/contract (embed this) - (->m void?) + (integer-bytes->integer (read-bytes 2 (match ip-or-bytes + [(? bytes? bs) (open-input-bytes bs)] + [ip ip])) signed big-endian)) - (unless (· this obj) - (set-field! obj this - (make-ref - (mhash - 'Type "XObject" - 'Subtype "Image" - 'BitsPerComponent (· this bits) - 'Width (· this width) - 'Height (· this height) - 'ColorSpace (· this colorSpace) - 'Filter "DCTDecode"))) - - ;; add extra decode params for CMYK images. By swapping the - ;; min and max values from the default, we invert the colors. See - ;; section 4.8.4 of the spec. - (when (equal? (· this colorSpace) "DeviceCMYK") - (dict-set! (· this obj) 'Decode '(1.0 0.0 1.0 0.0 1.0 0.0 1.0 0.0))) - (port-position (· this data) 0) - (send* (· this obj) [write (· this data)] - [end]))) (module+ test (require rackunit)