diff options
Diffstat (limited to 'pict.scm')
| -rw-r--r-- | pict.scm | 62 |
1 files changed, 50 insertions, 12 deletions
@@ -19,10 +19,13 @@ (define-module (pict) #:use-module (pict sxml) + #:use-module (pict base64) #:use-module ((sxml simple) #:hide (xml->sxml)) #:use-module (sxml transform) #:use-module (sxml fold) #:use-module ((sxml xpath) #:hide (filter)) + #:use-module (ice-9 binary-ports) + #:use-module (rnrs bytevectors) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) #:use-module (srfi srfi-9 gnu) @@ -148,21 +151,56 @@ list VALS." '(0 . ()) (cons 0 vals)))) +(define (png-size file-name) + "Return two values: width and height of the PNG file at FILE-NAME." + (define (bv->size bv) + (car (bytevector->uint-list bv (endianness big) 4))) + (call-with-input-file file-name + (lambda (port) + (get-bytevector-n port 8) ; throw away header + (get-bytevector-n port 4) ; throw away first chunk length + (if (bytevector=? (get-bytevector-n port 4) + #vu8(73 72 68 82)) ; IHDR + (values + (bv->size (get-bytevector-n port 4)) ; width + (bv->size (get-bytevector-n port 4))) ; height + (values #f #f))))) + (define (pict-from-file file-name) "Attempt to read FILE-NAME, convert its contents to SXML and wrap it in a <PICT> record. If this fails return #F." - (catch 'parser-error - (lambda () - (make-pict - (match (call-with-input-file file-name xml->sxml) - (('*TOP* ('*PI* . rest) svg) svg) - (('*TOP* svg) svg)))) - (lambda _ - (format (current-error-port) - "Failed to parse picture from file `~a'.~%\ -Is this really an SVG file?~%" - file-name) - #f))) + (let ((header (call-with-input-file file-name + (lambda (port) (get-bytevector-n port 8))))) + (make-pict + (match header + (#vu8(137 80 78 71 13 10 26 10) ; PNG + (call-with-values + (lambda () (png-size file-name)) + (lambda (width height) + `(svg (@ (width ,width) + (height ,height) + (xmlns "http://www.w3.org/2000/svg") + (xmlns:xlink "http://www.w3.org/1999/xlink")) + (image (@ (width ,width) + (height ,height) + (xlink:href + ,(string-append + "data:image/png;base64," + (call-with-input-file file-name + (lambda (port) + (base64-encode (get-bytevector-all port))) + #:binary #t))))))))) + (_ ; Assume SVG + (catch 'parser-error + (lambda () + (match (call-with-input-file file-name xml->sxml) + (('*TOP* ('*PI* . rest) svg) svg) + (('*TOP* svg) svg))) + (lambda args + (format (current-error-port) + "Failed to load picture from file `~a'.~%Only PNG or SVG are supported.~%~a~%" + file-name args) + #f))))))) ;;; SXML utilities |