From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.org!not-for-mail From: Kevin Ryde Newsgroups: gmane.emacs.devel Subject: image-mode showing text title/description/etc Date: Thu, 24 May 2007 08:40:46 +1000 Message-ID: <87myzvmadt.fsf@zip.com.au> NNTP-Posting-Host: lo.gmane.org Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" X-Trace: sea.gmane.org 1179959982 13399 80.91.229.12 (23 May 2007 22:39:42 GMT) X-Complaints-To: usenet@sea.gmane.org NNTP-Posting-Date: Wed, 23 May 2007 22:39:42 +0000 (UTC) To: emacs-devel@gnu.org Original-X-From: emacs-devel-bounces+ged-emacs-devel=m.gmane.org@gnu.org Thu May 24 00:39:33 2007 Return-path: Envelope-to: ged-emacs-devel@m.gmane.org Original-Received: from lists.gnu.org ([199.232.76.165]) by lo.gmane.org with esmtp (Exim 4.50) id 1HqzUJ-0006mx-U3 for ged-emacs-devel@m.gmane.org; Thu, 24 May 2007 00:39:29 +0200 Original-Received: from localhost ([127.0.0.1] helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.43) id 1HqzUK-0005Fn-PL for ged-emacs-devel@m.gmane.org; Wed, 23 May 2007 18:39:24 -0400 Original-Received: from mailman by lists.gnu.org with tmda-scanned (Exim 4.43) id 1HqzUF-0005Ek-J3 for emacs-devel@gnu.org; Wed, 23 May 2007 18:39:19 -0400 Original-Received: from exim by lists.gnu.org with spam-scanned (Exim 4.43) id 1HqzUD-0005E8-Fh for emacs-devel@gnu.org; Wed, 23 May 2007 18:39:19 -0400 Original-Received: from [199.232.76.173] (helo=monty-python.gnu.org) by lists.gnu.org with esmtp (Exim 4.43) id 1HqzUD-0005Dz-8T for emacs-devel@gnu.org; Wed, 23 May 2007 18:39:17 -0400 Original-Received: from mailout2-6.pacific.net.au ([61.8.2.229] helo=mailout2.pacific.net.au) by monty-python.gnu.org with esmtp (Exim 4.60) (envelope-from ) id 1HqzUA-0003Ci-Ic for emacs-devel@gnu.org; Wed, 23 May 2007 18:39:17 -0400 Original-Received: from mailproxy1.pacific.net.au (mailproxy1.pacific.net.au [61.8.2.162]) by mailout2.pacific.net.au (Postfix) with ESMTP id 7F6F86EF77 for ; Thu, 24 May 2007 08:39:00 +1000 (EST) Original-Received: from localhost (ppp2D4D.dyn.pacific.net.au [61.8.45.77]) by mailproxy1.pacific.net.au (Postfix) with ESMTP id ACD3C8C06 for ; Thu, 24 May 2007 08:39:00 +1000 (EST) Original-Received: from gg by localhost with local (Exim 4.67) (envelope-from ) id 1HqzVg-0002nm-2t for emacs-devel@gnu.org; Thu, 24 May 2007 08:40:48 +1000 User-Agent: Gnus/5.110007 (No Gnus v0.7) Emacs/22.0.99 (gnu/linux) X-detected-kernel: Linux 2.6, seldom 2.4 (older, 4) X-BeenThere: emacs-devel@gnu.org X-Mailman-Version: 2.1.5 Precedence: list List-Id: "Emacs development discussions." List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Original-Sender: emacs-devel-bounces+ged-emacs-devel=m.gmane.org@gnu.org Errors-To: emacs-devel-bounces+ged-emacs-devel=m.gmane.org@gnu.org Xref: news.gmane.org gmane.emacs.devel:71688 Archived-At: --=-=-= This is my idea to have image-mode display text from an image. The motivation is that showing an image title is clearly a good thing, and then showing author, long description, and copyright info are all pretty useful. But I'm not inclined to go into great detail about image characteristics, there's tools for doing that already, just stick to the text bits. The crunching is in lisp (at least initially) because it's more flexible than working up an interface to the various C libraries and then worrying what they can or can't give (libpng 1.2 for instance doesn't have iTXt enabled by default). Oh and lisp of course can't have any security problems, for those who worry about the doubtful record of some of the libraries on that. The zlib decompression is a nasty hack via gzip, but zlib.c below is an idea for a primitive. It works, but perhaps I've made some horrible mistake through ignorance. I also used a bindat null terminated string parse (ie. go up to the next \0 however far that is). It'd be a nice feature for bindat to have builtin, but I couldn't think of a good name, or a good flag for the existing strz (which is nulterm but only in a fixed length field). 2007-05-24 Kevin Ryde * image-mode.el: Display text comments in image files. Let the mode work on a tty so text can be seen there too. Don't hide the cursor, need it on the text. Don't truncate-lines, prefer to wrap the text. Diff and whole file, whichever is easier to review: --=-=-= Content-Type: text/x-diff Content-Disposition: attachment; filename=image-mode.el.diff *** /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"))))) --=-=-= Content-Type: application/emacs-lisp Content-Disposition: attachment; filename=image-mode.el Content-Transfer-Encoding: quoted-printable ;;; image-mode.el --- support for visiting image files ;; ;; Copyright (C) 2005, 2006, 2007 Free Software Foundation, Inc. ;; ;; Author: Richard Stallman ;; Keywords: multimedia ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;; Defines a major mode for visiting image files ;; that allows conversion between viewing the text of the file ;; and viewing the file as an image. Viewing the image ;; works by putting a `display' text-property on the ;; image data, with the image-data still present underneath; if the ;; resulting buffer file is saved to another name it will correctly save ;; the image data to the new file. ;;; Code: (require 'image) (require 'bindat) ;;;###autoload (push '("\\.jpe?g\\'" . image-mode) auto-mode-alist) ;;;###autoload (push '("\\.png\\'" . image-mode) auto-mode-alist) ;;;###autoload (push '("\\.gif\\'" . image-mode) auto-mode-alist) ;;;###autoload (push '("\\.tiff?\\'" . image-mode) auto-mode-alist) ;;;###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 (=3D 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 ((=3D 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 (=3D 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 =3D 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 ((=3D #xFFD9 marker) ;; EOI ;; stop, in case garbage after (setq pos (length raw))) ((=3D #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)))) ((=3D #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)))) ((=3D #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 (/=3D 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 <=3D 4 bytes in the field. We test only ;; count<=3D4 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 (<=3D 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 (=3D 2 (bindat-get-field entry :type))) ;; ASCII ;; The value offset field is a 32-bit file position, except if ;; the field is <=3D 4 bytes, in which case the bytes are inl= ine ;; 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 (/=3D 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 (=3D #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 ((=3D #x3B type) ;; trailer ) ((=3D #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 (=3D #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)) (/=3D 0 blocklen))))) ((=3D #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)) (/=3D 0 blocklen))) (cond ((=3D #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) map) "Major mode keymap for Image mode.") ;;;###autoload (defun image-mode () "Major mode for image files. You can use \\\\[image-toggle-display] to toggle between display as an image and display as text." (interactive) (kill-all-local-variables) (setq mode-name "Image") (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 "Toggle Image minor mode. With arg, turn Image minor mode on if arg is positive, off otherwise. See the command `image-mode' for more information on this mode." nil " Image" image-mode-map :group 'image :version "22.1" (if (not image-minor-mode) (image-toggle-display-text) (if (get-text-property (point-min) 'display) (setq cursor-type nil truncate-lines t)) (add-hook 'change-major-mode-hook (lambda () (image-minor-mode -1)) nil= t) (message "%s" (concat (substitute-command-keys "Type \\[image-toggle-display] to view the image as ") (if (get-text-property (point-min) 'display) "text" "an image") ".")))) ;;;###autoload (defun image-mode-maybe () "Set major or minor mode for image files. Set Image major mode only when there are no other major modes associated with a filename in `auto-mode-alist'. When an image filename matches another major mode in `auto-mode-alist' then set that major mode and Image minor mode. See commands `image-mode' and `image-minor-mode' for more information on these modes." (interactive) (let* ((mode-alist (delq nil (mapcar (lambda (elt) (unless (memq (or (car-safe (cdr elt)) (cdr elt)) '(image-mode image-mode-maybe)) elt)) auto-mode-alist)))) (if (assoc-default buffer-file-name mode-alist 'string-match) (let ((auto-mode-alist mode-alist) (magic-mode-alist nil)) (set-auto-mode) (image-minor-mode t)) (image-mode)))) (defun image-toggle-display-text () "Showing the text of the image file." (if (get-text-property (point-min) 'display) (image-toggle-display))) (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 and showing the image as an image." (interactive) (if (get-text-property (point-min) 'display) (let ((inhibit-read-only t) (buffer-undo-list t) (modified (buffer-modified-p))) (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) (not (file-remote-p filename)) (not (buffer-modified-p)) (not (and (boundp 'archive-superior-buffer) archive-superior-buffer)) (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 ima= ge, ;; 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"= ))))) (provide 'image-mode) ;; arch-tag: b5b2b7e6-26a7-4b79-96e3-1546b5c4c6cb ;;; image-mode.el ends here --=-=-= Content-Type: text/x-csrc Content-Disposition: attachment; filename=zlib.c #include /* z.msg can be NULL if there's no message, in particular for zero length input inflate() returns Z_BUF_ERROR with z.msg==NULL */ Lisp_Object make_z_stream_msg (z_stream *zp, int ret) { if (zp->msg != NULL) return build_string (zp->msg); else return concat2 (build_string ("Zlib error code "), Fnumber_to_string (make_number (ret))); } DEFUN ("zlib-inflate-string", Fzlib_inflate_string, Szlib_inflate_string, 1, 1, 0, doc: /* Inflate Zlib or Gzip format compressed data. STR is a unibyte string of compressed data in either Zlib (RFC 1950) or Gzip (RFC 1952) format. The return is a unibyte string of the decompressed result. An error is thrown for invalid contents. */) (str) Lisp_Object str; { z_stream z; int ret; char buf[4096]; Lisp_Object lst = Qnil; CHECK_STRING (str); z.zalloc = Z_NULL; z.zfree = Z_NULL; z.opaque = Z_NULL; z.next_in = (Bytef *) SDATA (str); z.avail_in = SBYTES (str); z.next_out = (Bytef *) buf; z.avail_out = sizeof (buf); /* ask to accept either gzip or zlib header formats */ ret = inflateInit2 (&z, 32 + 15); if (ret != Z_OK) xsignal1 (Qerror, concat2 (build_string ("Zlib inflateInit2: "), make_z_stream_msg (&z, ret))); for (;;) { ret = inflate (&z, Z_NO_FLUSH); if (ret != Z_OK && ret != Z_STREAM_END) { Lisp_Object msg = make_z_stream_msg (&z, ret); inflateEnd (&z); xsignal1 (Qerror, concat2 (build_string ("Zlib inflate: "), msg)); } if (z.avail_out == 0 || ret == Z_STREAM_END) { lst = Fcons (make_unibyte_string (buf, sizeof (buf) - z.avail_out), lst); z.next_out = (Bytef *) buf; z.avail_out = sizeof (buf); } if (ret == Z_STREAM_END) break; } if (z.avail_in != 0) { ret = inflateEnd (&z); error ("Garbage after compressed data"); } ret = inflateEnd (&z); if (ret != Z_OK) xsignal1 (Qerror, concat2 (build_string ("Zlib inflateEnd: "), make_z_stream_msg (&z, ret))); return apply1 (intern ("concat"), Fnreverse (lst)); } --=-=-= Content-Type: text/plain; charset="us-ascii" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit Content-Disposition: inline _______________________________________________ Emacs-devel mailing list Emacs-devel@gnu.org http://lists.gnu.org/mailman/listinfo/emacs-devel --=-=-=--