1#lang racket/base 2(require ffi/unsafe 3 ffi/unsafe/define 4 ffi/unsafe/alloc 5 "../private/utils.rkt" 6 "../private/libs.rkt" 7 "callback.rkt") 8 9(define-runtime-lib png-lib 10 [(unix) 11 ;; Most Linux distros supply "libpng12", while other Unix 12 ;; variants often have just "libpng", etc. 13 (let loop ([alts '(("libpng16" ("16" "")) 14 ("libpng15" ("15" "")) 15 ("libpng12" ("0" "")))]) 16 (cond 17 [(null? alts) (ffi-lib "libpng")] 18 [else (apply ffi-lib (car alts) 19 #:fail (lambda () 20 (loop (cdr alts))))]))] 21 [(macosx) (ffi-lib "libpng16.16.dylib")] 22 [(windows) 23 (ffi-lib "zlib1.dll") 24 (ffi-lib "libpng16-16.dll")]) 25 26(define-ffi-definer define-png png-lib 27 #:provide provide) 28 29(define-png png_access_version_number (_fun -> _uint32)) 30 31;; We support version 1.2 and 1.4... and (WARNING!) we'll optimisitically 32;; assume that other versions are also ok 33(define PNG_LIBPNG_VER_STRING (string->bytes/latin-1 34 (let ([v (png_access_version_number)]) 35 (format "~s.~s~a" 36 (quotient v 10000) 37 (quotient (remainder v 10000) 100) 38 (if (zero? (remainder v 100)) 39 "" 40 (format ".~a" (remainder v 100))))))) 41 42(define _png_structp (_cpointer 'png_structp)) 43(define _png_infop (_cpointer 'png_infop)) 44(define _png_end_infop (_cpointer 'png_end_infop)) 45(define _png_size_t _long) 46 47(define-cstruct _png_color_16 ([index _byte] 48 [red _uint16] 49 [green _uint16] 50 [blue _uint16] 51 [gray _uint16])) 52 53(define-png png_create_read_struct 54 (_fun _bytes 55 _pointer 56 (_fun #:keep (lambda (v) ((current-fun-keep) v)) 57 #:atomic? callback-atomic? 58 _png_structp _string -> _void) 59 (_fun #:keep (lambda (v) ((current-fun-keep) v)) 60 #:atomic? callback-atomic? 61 _png_structp _string -> _void) 62 -> _png_structp)) 63 64(define png_destroy_read_struct1 65 (get-ffi-obj 'png_destroy_read_struct 66 png-lib 67 (_fun (_ptr i _png_structp) 68 (_pointer = #f) 69 (_pointer = #f) 70 -> _void))) 71(define png_destroy_read_struct2 72 (get-ffi-obj 'png_destroy_read_struct 73 png-lib 74 (_fun (_ptr i _png_structp) 75 (_ptr i _png_infop) 76 (_pointer = #f) 77 -> _void))) 78 79(define-png png_create_write_struct 80 (_fun _bytes 81 _pointer 82 (_fun #:keep (lambda (v) ((current-fun-keep) v)) 83 #:atomic? callback-atomic? 84 _png_structp _string -> _void) 85 (_fun #:keep (lambda (v) ((current-fun-keep) v)) 86 #:atomic? callback-atomic? 87 _png_structp _string -> _void) 88 -> _png_structp)) 89(define png_destroy_write_struct1 90 (get-ffi-obj 'png_destroy_write_struct 91 png-lib 92 (_fun (_ptr i _png_structp) 93 (_pointer = #f) 94 -> _void))) 95(define png_destroy_write_struct2 96 (get-ffi-obj 'png_destroy_write_struct 97 png-lib 98 (_fun (_ptr i _png_structp) 99 (_ptr i _png_infop) 100 -> _void))) 101 102(define-png png_create_info_struct (_fun _png_structp -> _png_infop)) 103(define-png png_read_info (_fun #:callback-exns? callback-atomic? _png_structp _png_infop -> _void)) 104(define-png png_read_end (_fun #:callback-exns? callback-atomic? _png_structp _png_infop -> _void)) 105(define-png png_write_info (_fun _png_structp _png_infop -> _void)) 106 107(define-png png_read_update_info (_fun _png_structp _png_infop -> _void)) 108 109(define-png png_get_IHDR (_fun _png_structp 110 _png_infop 111 (w : (_ptr o _uint32)) 112 (h : (_ptr o _uint32)) 113 (depth : (_ptr o _int)) 114 (color-type : (_ptr o _int)) 115 (interlace-type : (_ptr o _int)) 116 (compression-type : (_ptr o _int)) 117 (filter-type : (_ptr o _int)) 118 -> _void 119 -> (values w h depth 120 color-type 121 interlace-type 122 compression-type 123 filter-type))) 124 125(define-png png_set_IHDR (_fun _png_structp 126 _png_infop 127 _uint32 128 _uint32 129 _int 130 _int _int _int _int 131 -> _void)) 132 133(define current-fun-keep (make-parameter #f)) 134 135(define-png png_set_read_fn (_fun _png_structp 136 _pointer 137 (_fun #:keep (lambda (v) ((current-fun-keep) v)) 138 #:atomic? callback-atomic? 139 _png_structp 140 _pointer 141 _png_size_t 142 -> _void) 143 -> _void)) 144(define-png png_set_write_fn (_fun _png_structp 145 _pointer 146 (_fun #:keep (lambda (v) ((current-fun-keep) v)) 147 #:atomic? callback-atomic? 148 _png_structp 149 _pointer 150 _png_size_t 151 -> _void) 152 (_fun #:keep (lambda (v) ((current-fun-keep) v)) 153 #:atomic? callback-atomic? 154 _png_structp 155 -> _void) 156 -> _void)) 157(define-png png_get_io_ptr (_fun _png_structp -> _pointer)) 158 159(define-png png_get_rowbytes (_fun #:callback-exns? callback-atomic? _png_structp _png_infop -> _uint32)) 160(define-png png_read_rows (_fun #:callback-exns? callback-atomic? _png_structp _pointer #;(_vector i _bytes) _pointer _uint32 -> _void)) 161(define-png png_write_image (_fun #:callback-exns? callback-atomic? _png_structp _pointer #;(_vector i _bytes) -> _void)) 162 163(define-png png_write_end (_fun #:callback-exns? callback-atomic? _png_structp _png_infop -> _void)) 164 165(define-png png_get_valid (_fun _png_structp _png_infop _uint32 -> _uint32)) 166(define-png png_get_bKGD (_fun _png_structp _png_infop (p : (_ptr o _png_color_16-pointer/null)) -> (r : _bool) -> (and r p))) 167(define-png png_set_background (_fun _png_structp _png_color_16-pointer _int _int _double* -> _bool)) 168(define-png png_get_gAMA (_fun _png_structp _png_infop (g : (_ptr o _double)) 169 -> (ok? : _bool) 170 -> (and ok? g))) 171(define-png png_set_gamma (_fun _png_structp _double* _double* -> _void)) 172(define-png png_set_filler (_fun _png_structp _uint32 _int -> _void)) 173 174(define-png png_set_invert_alpha (_fun _png_structp -> _void)) 175(define-png png_set_palette_to_rgb (_fun _png_structp -> _void)) 176(define-png png_set_gray_to_rgb (_fun _png_structp -> _void)) 177(define-png png_set_tRNS_to_alpha (_fun _png_structp -> _void)) 178(define-png png_set_strip_16 (_fun _png_structp -> _void)) 179(define-png png_set_strip_alpha (_fun _png_structp -> _void)) 180(define-png png_set_gray_1_2_4_to_8 (_fun _png_structp -> _void) 181 #:fail (lambda () #f)) 182(define-png png_set_expand_gray_1_2_4_to_8 (_fun _png_structp -> _void) 183 #:fail (lambda () #f)) 184(define-png png_set_interlace_handling (_fun _png_structp -> _int)) 185 186(define/provide PNG_COLOR_MASK_PALETTE 1) 187(define/provide PNG_COLOR_MASK_COLOR 2) 188(define/provide PNG_COLOR_MASK_ALPHA 4) 189 190(define/provide PNG_COLOR_TYPE_GRAY 0) 191(define/provide PNG_COLOR_TYPE_PALETTE (bitwise-ior PNG_COLOR_MASK_COLOR PNG_COLOR_MASK_PALETTE)) 192(define/provide PNG_COLOR_TYPE_RGB PNG_COLOR_MASK_COLOR) 193(define/provide PNG_COLOR_TYPE_RGB_ALPHA (bitwise-ior PNG_COLOR_MASK_COLOR PNG_COLOR_MASK_ALPHA)) 194(define/provide PNG_COLOR_TYPE_GRAY_ALPHA PNG_COLOR_MASK_ALPHA) 195 196(define/provide PNG_INTERLACE_NONE 0) 197(define/provide PNG_INTERLACE_ADAM7 1) 198 199(define/provide PNG_FILTER_TYPE_BASE 0) 200(define/provide PNG_INTRAPIXEL_DIFFERENCING 64) 201(define/provide PNG_FILTER_TYPE_DEFAULT PNG_FILTER_TYPE_BASE) 202 203(define/provide PNG_COMPRESSION_TYPE_BASE 0) 204(define/provide PNG_COMPRESSION_TYPE_DEFAULT PNG_COMPRESSION_TYPE_BASE) 205 206(define/provide PNG_BACKGROUND_GAMMA_UNKNOWN 0) 207(define/provide PNG_BACKGROUND_GAMMA_SCREEN 1) 208(define/provide PNG_BACKGROUND_GAMMA_FILE 2) 209(define/provide PNG_BACKGROUND_GAMMA_UNIQUE 3) 210 211(define/provide PNG_INFO_tRNS #x0010) 212 213(define PNG_FILLER_BEFORE 0) 214(define PNG_FILLER_AFTER 1) 215 216;; ---------------------------------------- 217;; Reading 218 219(provide create-png-reader 220 read-png 221 destroy-png-reader) 222 223(define-struct reader ([png #:mutable] info ib num-passes w h)) 224 225(define (error-esc v s) 226 (error 'png "~a" s)) 227 228(define (read-png-bytes png p len) 229 (define bstr (make-bytes len)) 230 (define n (read-bytes! bstr (car (ptr-ref (png_get_io_ptr png) _scheme)))) 231 (cond 232 [(eof-object? n) 0] 233 [else 234 (memcpy p bstr n) 235 n])) 236 237(define free-cell ((deallocator) free-immobile-cell)) 238(define make-cell ((allocator free-cell) malloc-immobile-cell)) 239 240(define (create-png-reader in keep-alpha? bg-rgb) 241 (let* ([funs (box null)] 242 [fun-keep (lambda (v) 243 (set-box! funs (cons v (unbox funs))))] 244 [png (parameterize ([current-fun-keep fun-keep]) 245 (png_create_read_struct PNG_LIBPNG_VER_STRING #f error-esc void))] 246 [info (png_create_info_struct png)] 247 [ib (make-cell (cons (sanitize-input-port in) funs))]) 248 (parameterize ([current-fun-keep fun-keep]) 249 (png_set_read_fn png ib read-png-bytes)) 250 (png_read_info png info) 251 (let-values ([(w h depth color-type 252 interlace-type compression-type filter-type) 253 (png_get_IHDR png info)]) 254 (let* ([tRNS? (positive? (png_get_valid png info PNG_INFO_tRNS))] 255 [b&w? (and (= depth 1) 256 (= color-type PNG_COLOR_TYPE_GRAY) 257 (not tRNS?))] 258 [alpha? (and keep-alpha? 259 (not b&w?) 260 (or tRNS? 261 (positive? (bitwise-ior color-type PNG_COLOR_MASK_ALPHA))))]) 262 (unless b&w? 263 ;; Normalize formal of returned rows: 264 (when (= color-type PNG_COLOR_TYPE_PALETTE) 265 (png_set_palette_to_rgb png)) 266 (when (or (= color-type PNG_COLOR_TYPE_GRAY) 267 (= color-type PNG_COLOR_TYPE_GRAY_ALPHA)) 268 (png_set_gray_to_rgb png)) 269 (when tRNS? 270 (png_set_tRNS_to_alpha png)) 271 (when (= depth 16) 272 (png_set_strip_16 png)) 273 ;; Expand grayscale images to the full 8 bits from 1, 2, or 4 bits/pixel 274 ((or png_set_gray_1_2_4_to_8 png_set_expand_gray_1_2_4_to_8) png)) 275 (unless (or alpha? b&w?) 276 ;; Set the background color to draw transparent and alpha images over. 277 (let* ([deep (lambda (n) 278 (if (= depth 16) 279 (+ n (arithmetic-shift n 8)) 280 n))] 281 [bg (make-png_color_16 0 (deep 255) (deep 255) (deep 255) (deep 255))]) 282 (cond 283 [bg-rgb (set-png_color_16-red! bg (deep (car bg-rgb))) 284 (set-png_color_16-green! bg (deep (cadr bg-rgb))) 285 (set-png_color_16-blue! bg (deep (caddr bg-rgb))) 286 (set-png_color_16-gray! bg (deep (floor (/ (apply + bg-rgb) 3))))] 287 [else (let ([c (png_get_bKGD png info)]) 288 (when c 289 (memcpy bg c (ctype-sizeof _png_color_16))))]) 290 (png_set_background png bg 291 (if bg-rgb 292 PNG_BACKGROUND_GAMMA_SCREEN 293 PNG_BACKGROUND_GAMMA_FILE) 294 0 1.0))) 295 (let ([gamma (png_get_gAMA png info)]) 296 (when gamma 297 (let* ([s (getenv "SCREEN_GAMMA")] 298 [screen-gamma (and s (string->number s))]) 299 (png_set_gamma png (if (and (real? screen-gamma) 300 (<= 0.0 screen-gamma 10.0)) 301 screen-gamma 302 2.2) 303 gamma)))) 304 (cond 305 [alpha? 306 ;; Make sure there's an alpha or filler byte (before each RGB triplet): 307 (png_set_filler png 255 PNG_FILLER_AFTER)] 308 [tRNS? 309 ;; Make sure there's no alpha channel: 310 (png_set_strip_alpha png)]) 311 (let ([num-passes (png_set_interlace_handling png)]) 312 (png_read_update_info png info) 313 (values (make-reader png info ib num-passes w h) 314 w h 315 b&w? 316 alpha?)))))) 317 318(define (malloc-rows h row-bytes) 319 (let* ([align (lambda (v) (if (positive? (remainder v 8)) 320 (+ v (- 8 (remainder v 8))) 321 v))] 322 [table-size (align (* h (ctype-sizeof _pointer)))] 323 [row-size (align row-bytes)] 324 [memory (malloc (+ table-size (* row-size h)) 325 'atomic-interior)] 326 [rows memory]) 327 (for ([i (in-range h)]) 328 (ptr-set! rows _pointer i (ptr-add memory (+ table-size (* i row-size))))) 329 rows)) 330 331(define (read-png reader) 332 (let* ([row-bytes (png_get_rowbytes (reader-png reader) (reader-info reader))] 333 [rows (malloc-rows (reader-h reader) row-bytes)]) 334 (for ([i (in-range (reader-num-passes reader))]) 335 (png_read_rows (reader-png reader) rows #f (reader-h reader))) 336 (png_read_end (reader-png reader) (reader-info reader)) 337 (list->vector 338 (for/list ([i (in-range (reader-h reader))]) 339 (define p (ptr-ref rows _pointer i)) 340 (define bstr (make-bytes row-bytes)) 341 (memcpy bstr p row-bytes) 342 (void/reference-sink rows) ; keep alive until memcpy is done 343 bstr)))) 344 345(define (destroy-png-reader reader) 346 (when (reader-png reader) 347 (png_destroy_read_struct2 (reader-png reader) 348 (reader-info reader)) 349 (free-cell (reader-ib reader)) 350 (set-reader-png! reader #f))) 351 352;; ---------------------------------------- 353;; Writing 354 355(provide create-png-writer 356 write-png 357 destroy-png-writer) 358 359(define-struct writer (png info ob)) 360 361(define (write-png-bytes png p len) 362 (define bstr (make-bytes len)) 363 (memcpy bstr p len) 364 (write-bytes bstr (car (ptr-ref (png_get_io_ptr png) _scheme)))) 365 366(define (flush-png-bytes png) 367 (flush-output (car (ptr-ref (png_get_io_ptr png) _scheme)))) 368 369(define (create-png-writer out w h b&w? alpha?) 370 (let* ([funs (box null)] 371 [fun-keep (lambda (v) 372 (set-box! funs (cons v (unbox funs))))] 373 [png (parameterize ([current-fun-keep fun-keep]) 374 (png_create_write_struct PNG_LIBPNG_VER_STRING #f error-esc void))] 375 [info (png_create_info_struct png)] 376 [ob (make-cell (cons (sanitize-output-port out #:key info) funs))]) 377 (parameterize ([current-fun-keep fun-keep]) 378 (png_set_write_fn png ob write-png-bytes flush-png-bytes)) 379 (png_set_IHDR png info w h (if b&w? 1 8) 380 (cond 381 [b&w? PNG_COLOR_TYPE_GRAY] 382 [alpha? PNG_COLOR_TYPE_RGB_ALPHA] 383 [else PNG_COLOR_TYPE_RGB]) 384 PNG_INTERLACE_NONE PNG_COMPRESSION_TYPE_DEFAULT 385 PNG_FILTER_TYPE_DEFAULT) 386 (png_write_info png info) 387 (make-writer png info ob))) 388 389(define (write-png writer vector-of-rows) 390 (if (zero? (vector-length vector-of-rows)) 391 (png_write_image (writer-png writer) #f) 392 (let* ([h (vector-length vector-of-rows)] 393 [w (bytes-length (vector-ref vector-of-rows 0))] 394 [rows (malloc-rows h w)]) 395 (for/list ([i (in-range h)]) 396 (memcpy (ptr-ref rows _pointer i) 397 (vector-ref vector-of-rows i) 398 w)) 399 (png_write_image (writer-png writer) rows))) 400 (png_write_end (writer-png writer) (writer-info writer)) 401 (flush-sanitized-output (writer-info writer))) 402 403(define (destroy-png-writer writer) 404 (png_destroy_write_struct2 (writer-png writer) 405 (writer-info writer)) 406 (free-cell (writer-ob writer))) 407