*** /down/emacs/lisp/image-mode.el 2007-05-24 07:44:47.000000000 +1000 --- image-mode.el 2007-05-24 08:02:16.000000000 +1000 *************** *** 35,40 **** --- 35,41 ---- ;;; Code: (require 'image) + (require 'bindat) ;;;###autoload (push '("\\.jpe?g\\'" . image-mode) auto-mode-alist) ;;;###autoload (push '("\\.png\\'" . image-mode) auto-mode-alist) *************** *** 43,48 **** --- 44,532 ---- ;;;###autoload (push '("\\.p[bpgn]m\\'" . image-mode) auto-mode-alist) ;;;###autoload (push '("\\.x[bp]m\\'" . image-mode-maybe) auto-mode-alist) + + + ;; image strings + + ;; The concept here, as of now, is just to pick out interesting text parts + ;; of an image file, like title, author, copyright information etc. + ;; + ;; The pieces are shown in the order they're found in the file. PNG and GIF + ;; allow text in any order, so perhaps there'll be some significance to it. + ;; But TIFF (including JPEG EXIF) is supposed to be sorted by tag code, so + ;; there's not particular about the order there. + ;; + ;; There's lots more information which could be shown, things like colour + ;; spectrum, compression, scan directions, but that starts to get very + ;; technical. Perhaps some of that could be second-tier priority, shown + ;; after main info. But for now leave it to the heavy duty programs like + ;; imagemagick, exiftool, image-metadata-jpeg, etc, to go into details. + ;; + ;; Crunching image formats in lisp might look a bit like hard work, but it's + ;; also much more flexible than creating a mechanism and formats for getting + ;; stuff up from the C code image libraries. If there was any editing of + ;; the info in the future it'd be different, you'd probably want the image + ;; libraries to do that. + + (defun imagetext-strings (image raw) + "Extract text comments from an image. + IMAGE is the image descriptor, or a warning string if not displayable. + RAW is a unibyte string of image data. + The return is a list of strings describing the things found." + + ;; imagetext-png-strings and imagetext-gif-strings do the image size + ;; themselves (an in particular let that info come out on a tty) + (let ((type (image-type raw nil t))) + (condition-case err + (cond ((eq type 'png) (imagetext-png-strings raw)) + ((eq type 'gif) (imagetext-gif-strings raw)) + ((eq type 'jpeg) (append (imagetext-size-strings image) + (imagetext-jpeg-strings raw))) + ((eq type 'tiff) (append (imagetext-size-strings image) + (imagetext-tiff-strings raw))) + (t (imagetext-size-strings image))) + (error (list "Invalid or unrecognised image file contents\n" + (error-message-string err)))))) + + (defun imagetext-size-strings (image) + "Return a list of strings representing the size of IMAGE. + IMAGE is an image descriptor, or a warning string if not displayable." + + ;; `image-size' throws an error on a non-gui display, which is a shame + ;; because the image libraries can give the info without displaying + (let ((size (condition-case nil (image-size image t) (error nil)))) + (and size + (list (format "Size %dx%d\n" (car size) (cdr size)))))) + + (defun imagetext-bindat-nulterm () + "Pick out a nul-terminated string for a bindat specification. + For example + + (my-asciz-field eval (imagetext-bindat-nulterm)) + + The terminating 0 byte is skipped, and not included in the string + returned as the field value." + + ;; this implementation only for strings + (let ((zpos (or (string-match "\000" bindat-raw bindat-idx) + (error "No null terminator")))) + (prog1 (substring bindat-raw bindat-idx zpos) + (setq bindat-idx (1+ zpos))))) + + + ;; png strings + + (defun imagetext-png-strings (raw) + "Extract text comments from PNG image data. + RAW in the image data as a unibyte string, the return is a list + of text strings found (multibyte strings)." + + (let ((pos 8) + ret) + (while (< pos (length raw)) + ;; chunk + (let* ((struct (bindat-unpack '((:length u32) + (:type str 4) + (:data str (:length)) + (:crc str 4) + ((eval (setq pos bindat-idx)))) + raw pos)) + (type (bindat-get-field struct :type)) + (data (bindat-get-field struct :data))) + + (if nil ;; diagnostic message, disabled + (push (format "%s: %s bytes\n" type (length data)) ret)) + + (cond + ((string-equal type "IHDR") + (let* ((struct (bindat-unpack '((:width u32) + (:height u32)) data))) + (push (format "Size %dx%d\n" + (bindat-get-field struct :width) + (bindat-get-field struct :height)) + ret))) + + ((string-equal type "tEXt") + (let* ((struct (bindat-unpack + '((:keyword eval (imagetext-bindat-nulterm)) + (:text str (eval (- (length bindat-raw) + bindat-idx)))) + data))) + (push (format "%s: %s\n" + (decode-coding-string + (bindat-get-field struct :keyword) 'latin-1) + (decode-coding-string + (bindat-get-field struct :text) 'latin-1)) ret))) + + ((string-equal type "zTXt") + (let* ((struct (bindat-unpack + '((:keyword eval (imagetext-bindat-nulterm)) + (:method u8) + (:comptext str (eval (- (length bindat-raw) + bindat-idx)))) + data))) + (push (format "%s: %s\n" + (decode-coding-string + (bindat-get-field struct :keyword) 'latin-1) + (decode-coding-string + (imagetext-png-zTXt-inflate + (bindat-get-field struct :method) + (bindat-get-field struct :comptext)) + 'latin-1)) ret))) + + ((string-equal type "iTXt") + (let* ((struct (bindat-unpack + '((:keyword eval (imagetext-bindat-nulterm)) + (:compflag u8) + (:method u8) + (:lang eval (imagetext-bindat-nulterm)) + (:lkeyword eval (imagetext-bindat-nulterm)) + (:text str (eval (- (length bindat-raw) + bindat-idx)))) + data)) + (text (bindat-get-field struct :text))) + (if (= 1 (bindat-get-field struct :compflag)) + (setq text (imagetext-png-zTXt-inflate + (bindat-get-field struct :method) text))) + (push (format "%s %s %s: %s\n" + (decode-coding-string + (bindat-get-field struct :keyword) 'latin-1) + (decode-coding-string ;; supposed to be ascii + (bindat-get-field struct :lang) 'undecided) + (decode-coding-string + (bindat-get-field struct :lkeyword) 'utf-8) + (decode-coding-string text 'utf-8)) + ret))) + + ((string-equal type "tIME") + (let* ((struct (bindat-unpack '((:year u16) + (:month u8) + (:day u8) + (:hour u8) + (:minute u8) + (:second u8)) data))) + (push (format "%s: %d-%02d-%02d %02d:%02d:%02d\n" + type + (bindat-get-field struct :year) + (bindat-get-field struct :month) + (bindat-get-field struct :day) + (bindat-get-field struct :hour) + (bindat-get-field struct :minute) + (bindat-get-field struct :second)) + ret)))))) + (nreverse ret))) + + (defun imagetext-png-zTXt-inflate (method data) + "Inflate a PNG compresed data string. + METHOD is the integer method code, but only 0 for \"inflate\" is + supported, for others a warning message string is returned. + DATA is a unibyte string and on success the return is likewise a + unibyte string." + (cond ((= method 0) + (imagetext-inflate data)) + (t + (format "" method)))) + + (defun imagetext-inflate (str) + "Inflate Zlib format (RFC 1950) compressed data STR. + STR should be unibyte and the return is similarly a unibyte string. + + This is implemented by running the gzip program, which is pretty + nasty since usually Emacs has zlib linked in already (used by + libpng) so one day there might be a direct interface to it." + + (let* ((flg (aref str 1)) + (fdict (logand flg #x20)) + (cm (logand #x0F (aref str 0)))) + (if (= 01 fdict) + "" + + (with-temp-buffer + (set-buffer-multibyte nil) + (insert (string 31 139 ;; ID1,ID2 + cm ;; CM compression method + 0 ;; FLG flags + 0 0 0 0 ;; MTIME + 0 ;; XFL extra flags + 3)) ;; OS = Unix + (insert (substring str 2)) ;; drop CMF and FLG + (insert (string 0 0 0 0)) ;; ISIZE faked + (let* ((coding-system-for-read 'no-conversion) + (coding-system-for-write 'no-conversion) + (status (call-process-region (point-min) (point-max) "gzip" + t '(t nil) nil "-d"))) + ;; report if died by signal, other errors are expected because we + ;; leave the zlib ADLER32 checksum pretending to be CRC32 (wrong + ;; of course), and the ISIZE uncompressed size is faked + (when (stringp status) + (goto-char (point-min)) + (insert (format "" status)))) + (buffer-string))))) + + + ;; jpeg strings + + (defun imagetext-jpeg-strings (raw) + "Extract text comments from JPEG image data. + RAW in the image data as a unibyte string, the return is a list + of text strings found (multibyte strings)." + + (let ((pos 0) + ret) + + ;; skip to FF each time, to pass over ECS data + (while (setq pos (string-match "\377" raw pos)) + + (let* ((struct (bindat-unpack + '((:marker u16) + (union (eval last) + ;; escapes in ECS treated as marker only + (#xFF00) (#xFFFF) + ;; RST0 through RST7, marker only + (#xFFD0) (#xFFD1) (#xFFD2) (#xFFD3) + (#xFFD4) (#xFFD5) (#xFFD6) (#xFFD7) + ;; SOI and EOI, marker-only + (#xFFD8) (#xFFD9) + ;; otherwise length and data + (t (:length u16) + (:data str (eval (- last 2))))) + ((eval (setq pos bindat-idx)))) + raw pos)) + (marker (bindat-get-field struct :marker)) + (data (bindat-get-field struct :data))) + + (if nil ;; diagnostic message, disabled + (push (format "%x: %s bytes\n" marker (length data)) ret)) + + (cond ((= #xFFD9 marker) ;; EOI + ;; stop, in case garbage after + (setq pos (length raw))) + + ((= #xFFE0 marker) ;; APP0 + (if (or (eq t (compare-strings data 0 4 "JFIF" 0 4)) + (eq t (compare-strings data 0 4 "JFXX" 0 4))) + (let* ((struct (bindat-unpack '((:ident str 4) + (:null u8) + (:major-version u8) + (:minor-version u8)) + data))) + + (push (format "%s version %d.%02d\n" + (bindat-get-field struct :ident) + (bindat-get-field struct :major-version) + (bindat-get-field struct :minor-version)) + ret)))) + + ((= #xFFE1 marker) ;; APP1 + (if (eq t (compare-strings data 0 6 "Exif\000\000" 0 6)) + ;; exif is a segment of tiff data, including the usual + ;; tiff header + (setq ret (nconc (nreverse (imagetext-tiff-strings + (substring data 6))) + ret)))) + + ((= #xFFFE marker) ;; COM comment + ;; dunno what the text encoding should be, let emacs guess + (push (format "%s\n" + (decode-coding-string data 'undecided)) + ret))))) + (nreverse ret))) + + + ;; tiff strings (including EXIF within a JPEG) + + (defun imagetext-tiff-strings (raw) + "Extract text comments from TIFF image data. + RAW in the image data as a unibyte string, the return is a list + of text strings found (multibyte strings)." + + (let* (ret ifdpos X-u16 X-u32) + + ;; 8-byte header + ;; X-u16 setup as either 'u16 or 'u16r, according to the endianess, and + ;; likewise X-u32 + (let* ((struct (bindat-unpack '((:endian str 2) + ((eval (cond ((string-equal "MM" last) + (setq X-u16 'u16) + (setq X-u32 'u32)) + ((string-equal "II" last) + (setq X-u16 'u16r) + (setq X-u32 'u32r))))) + (:mark42 (eval X-u16)) + (:ifdpos (eval X-u32))) + raw))) + (setq ifdpos (bindat-get-field struct :ifdpos))) + + ;; loop looking at all IFDs in the file + ;; the second and subsequent are supposed to be about sub-images or + ;; something, so maybe ought to identify that somehow + (while (/= 0 ifdpos) + + ;; The count field is followed by 4 bytes which are either the field + ;; data there inline, or a 32-bit file position of the data. Inline + ;; is used when there's <= 4 bytes in the field. We test only + ;; count<=4 because that's enough for the ascii (count is bytes) + ;; fields we're interested in. (And we're safe if ever u32 decode got + ;; some overflow checking, because we err in treating some remotes as + ;; inline; any u32 decode is certainly a file offset.) + + (let* ((entry-spec '((:tag (eval X-u16)) + (:type (eval X-u16)) + (:count (eval X-u32)) + (union (eval last) + ((eval (<= tag 4)) + (:datapos eval bindat-idx) ;; inline + ( fill 4)) + (t + (:datapos (eval X-u32)))))) ;; remote + (struct (bindat-unpack '((:numentries (eval X-u16)) + (:entries repeat (:numentries) + (struct entry-spec)) + (:nextifd (eval X-u32))) + raw ifdpos))) + + ;; The alist is the tags to actually show, and only ascii ones + ;; supported. + ;; - #x13C "HostComputer" is not shown because that seems very + ;; irrelevant. + ;; - #x131 "Software" is shown; it's of doubtful interest, but in + ;; formats like PNG that kind of info shows up, so have it here + ;; for consistency. + ;; - #x10F "Make" and #x110 "Model" for the camera are + ;; possibilities, but would seem of very limited interest + ;; + (dolist (entry (bindat-get-field struct :entries)) + (let* ((tag (bindat-get-field entry :tag)) + (tagname (cdr (assoc tag + '((#x10D . "DocumentName") + (#x10E . "ImageDescription") + (#x11D . "PageName") + (#x131 . "Software") + (#x132 . "DateTime") + (#x13B . "Artist") + (#x8298 . "Copyright")))))) + + (if nil ;; diagnostic message, disabled + (push (format "tag %x\n" tag) ret)) + + (when (and tagname + (= 2 (bindat-get-field entry :type))) ;; ASCII + + ;; The value offset field is a 32-bit file position, except if + ;; the field is <= 4 bytes, in which case the bytes are inline + ;; there directly. The size of each count element varies + ;; according to the type, so we don't know how many bytes + ;; until identifying the type field, in this case ASCII data + ;; which means simply count bytes. (Want to avoid attempting + ;; a u32 decode until being sure it's really an offset, in + ;; case it's some strange bytes overflowing the conversion.) + ;; + (let* ((count (bindat-get-field entry :count)) + (datapos (bindat-get-field entry :datapos)) + (data (substring raw datapos (+ datapos count)))) + + ;; There's always a trailing \0, then any \0's in the middle + ;; separate multiple values such as multiple copyright + ;; holders in a #x8298 field. Ascii fields are supposed to + ;; be ascii, but let's decode as 'undecided just in case + ;; there's something zany. + ;; + (setq data (replace-regexp-in-string "\000\\'" "" data t t)) + (setq data (decode-coding-string data 'undecided)) + (dolist (str (split-string data "\000")) + (push (format "%s: %s\n" tagname str) ret)))))) + + (setq ifdpos (bindat-get-field struct :nextifd)) + (if (/= 0 ifdpos) + (push "\nSubfile:\n" ret)))) + + ret)) + + + ;; gif strings + + (defun imagetext-gif-strings (raw) + "Extract text comments from GIF image data. + RAW is the image data as a unibyte string, the return is a list + of text strings found (multibyte strings)." + + (let* ((pos 0) + ret) + + ;; header + (let* ((struct (bindat-unpack '((:sig+ver str 6) + (:width u16r) + (:height u16r) + (flags u8) + (background u8) + (aspect-ratio u8) + ((eval (setq pos bindat-idx)))) + raw)) + (flags (bindat-get-field struct 'flags)) + (gct-flag (= #x80 (logand #x80 flags))) + (gct-size (logand #x07 flags))) + + ;; global colour table 3*2^(gctsize+1) bytes, when flag set + (if gct-flag + (setq pos (+ pos (* 3 (ash 2 gct-size))))) + + (push (format "%s, size %dx%d\n" + (bindat-get-field struct :sig+ver) + (bindat-get-field struct :width) + (bindat-get-field struct :height)) + ret)) + + (while (< pos (length raw)) + (let* ((type (aref raw pos))) + (setq pos (1+ pos)) + + (cond ((= #x3B type) ;; trailer + ) + + ((= #x2C type) ;; image descriptor + (let* ((struct (bindat-unpack '((left u16r) + (top u16r) + (:width u16r) + (:height u16r) + (flags u8) + ((eval (setq pos bindat-idx)))) + raw pos)) + (flags (bindat-get-field struct 'flags)) + (lct-flag (= #x80 (logand #x80 flags))) + (lct-size (logand #x07 flags))) + ;; local colour table 3*2^(lctsize+1) bytes, when flag set + (if lct-flag + (setq pos (+ pos (* 3 (ash 2 lct-size))))) + + ;; table data + (setq pos (1+ pos)) ;; LZW minimum code size + ;; data blocks, first byte is length, stop at 0 len + (while (let ((blocklen (aref raw pos))) + (setq pos (+ pos 1 blocklen)) + (/= 0 blocklen))))) + + ((= #x21 type) ;; extension + (setq type (aref raw pos)) + (setq pos (1+ pos)) + + (let ((data "")) + ;; concat data blocks, first byte is length, stop at 0 len + (while (let ((blocklen (aref raw pos))) + (setq data (concat data + (substring raw (1+ pos) + (+ pos 1 blocklen)))) + (setq pos (+ pos 1 blocklen)) + (/= 0 blocklen))) + + (cond ((= #xFE type) ;; comment + ;; supposed to be 7-bit ascii, attempt a decode in case + (push (format "%s\n" + (decode-coding-string data 'undecided)) + ret)))))))) + (nreverse ret))) + + + (defvar image-mode-map (let ((map (make-sparse-keymap))) (define-key map "\C-c\C-c" 'image-toggle-display) *************** *** 60,78 **** (setq major-mode 'image-mode) (use-local-map image-mode-map) (add-hook 'change-major-mode-hook 'image-toggle-display-text nil t) ! (if (and (display-images-p) ! (not (get-text-property (point-min) 'display))) (image-toggle-display) ;; Set next vars when image is already displayed but local ;; variables were cleared by kill-all-local-variables (setq cursor-type nil truncate-lines t)) (run-mode-hooks 'image-mode-hook) ! (if (display-images-p) ! (message "%s" (concat ! (substitute-command-keys ! "Type \\[image-toggle-display] to view as ") ! (if (get-text-property (point-min) 'display) ! "text" "an image") ".")))) ;;;###autoload (define-minor-mode image-minor-mode --- 544,560 ---- (setq major-mode 'image-mode) (use-local-map image-mode-map) (add-hook 'change-major-mode-hook 'image-toggle-display-text nil t) ! (if (not (get-text-property (point-min) 'display)) (image-toggle-display) ;; Set next vars when image is already displayed but local ;; variables were cleared by kill-all-local-variables (setq cursor-type nil truncate-lines t)) (run-mode-hooks 'image-mode-hook) ! (message "%s" (concat ! (substitute-command-keys ! "Type \\[image-toggle-display] to view as ") ! (if (get-text-property (point-min) 'display) ! "text" "an image") "."))) ;;;###autoload (define-minor-mode image-minor-mode *************** *** 125,130 **** --- 607,617 ---- (defvar archive-superior-buffer) (defvar tar-superior-buffer) + (defvar image-mode-original-multibyte nil) + (make-variable-buffer-local 'image-mode-original-multibyte) + (defvar image-mode-text-marker nil) + (make-variable-buffer-local 'image-mode-text-marker) + (defun image-toggle-display () "Start or stop displaying an image file as the actual image. This command toggles between showing the text of the image file *************** *** 137,150 **** (remove-list-of-text-properties (point-min) (point-max) '(display intangible read-nonsticky read-only front-sticky)) (set-buffer-modified-p modified) ! (kill-local-variable 'cursor-type) ! (kill-local-variable 'truncate-lines) (if (called-interactively-p) (message "Repeat this command to go back to displaying the image"))) ;; Turn the image data into a real image, but only if the whole file ;; was inserted (let* ((filename (buffer-file-name)) (image (if (and filename (file-readable-p filename) --- 624,643 ---- (remove-list-of-text-properties (point-min) (point-max) '(display intangible read-nonsticky read-only front-sticky)) + (delete-region image-mode-text-marker (point-max)) + (set-buffer-multibyte image-mode-original-multibyte) (set-buffer-modified-p modified) ! (kill-local-variable 'image-mode-text-marker) ! (kill-local-variable 'image-mode-original-multibyte) ! ;; (kill-local-variable 'cursor-type) ! ;; (kill-local-variable 'truncate-lines) (if (called-interactively-p) (message "Repeat this command to go back to displaying the image"))) ;; Turn the image data into a real image, but only if the whole file ;; was inserted (let* ((filename (buffer-file-name)) + (raw (string-make-unibyte + (buffer-substring-no-properties (point-min) (point-max)))) (image (if (and filename (file-readable-p filename) *************** *** 155,184 **** (not (and (boundp 'tar-superior-buffer) tar-superior-buffer))) (create-image filename) ! (create-image ! (string-make-unibyte ! (buffer-substring-no-properties (point-min) (point-max))) ! nil t))) (props ! `(display ,image ! intangible ,image rear-nonsticky (display intangible) ;; This a cheap attempt to make the whole buffer ;; read-only when we're visiting the file (as ;; opposed to just inserting it). read-only t front-sticky (read-only))) (inhibit-read-only t) (buffer-undo-list t) (modified (buffer-modified-p))) (image-refresh image) (add-text-properties (point-min) (point-max) props) (set-buffer-modified-p modified) ! ;; Inhibit the cursor when the buffer contains only an image, ! ;; because cursors look very strange on top of images. ! (setq cursor-type nil) ;; This just makes the arrow displayed in the right fringe ;; area look correct when the image is wider than the window. ! (setq truncate-lines t) (if (called-interactively-p) (message "Repeat this command to go back to displaying the file as text"))))) --- 648,690 ---- (not (and (boundp 'tar-superior-buffer) tar-superior-buffer))) (create-image filename) ! (create-image raw nil t))) ! (imagedisp (if (display-images-p) ! image ! "[Image not displayable]")) (props ! `(display ,imagedisp ! intangible ,imagedisp rear-nonsticky (display intangible) ;; This a cheap attempt to make the whole buffer ;; read-only when we're visiting the file (as ;; opposed to just inserting it). read-only t front-sticky (read-only))) + (textlst (imagetext-strings image raw)) (inhibit-read-only t) (buffer-undo-list t) (modified (buffer-modified-p))) + (image-refresh image) + (setq image-mode-original-multibyte enable-multibyte-characters) + (set-buffer-multibyte t) (add-text-properties (point-min) (point-max) props) + (goto-char (point-max)) + (setq image-mode-text-marker (point-marker)) + (insert "\n\n") + (mapc 'insert textlst) + (goto-char (point-min)) + (set-buffer-modified-p modified) ! ! ;; Used to inhibit the cursor here because it looks strange on an image, ! ;; but now there's text we need it to navigate. ! ;; This just makes the arrow displayed in the right fringe ;; area look correct when the image is wider than the window. ! ;; But it's not good for text that goes past the window. ! ;; (setq truncate-lines t) ! (if (called-interactively-p) (message "Repeat this command to go back to displaying the file as text")))))