Re: [PATCH] Support opaque display-table objects on XEmacs
16 years, 11 months
Aidan Kehoe
Aidan Kehoe
Ar an seachtú lá is fiche de mí Bealtaine, scríobh Reiner Steib:
> On Thu, May 22 2008, Miles Bader wrote:
>
> > Aidan Kehoe <kehoea(a)parhasard.net> writes:
> >> This patch adds support for the non-sequence display tables of XEmacs
> >> 21.5, without any run-time overhead on GNU. A patch that’s equivalent
> >> in functionality for that version has been integrated into the XEmacs
> >> package repository; this conflicts with that, though--sorry Mike!--and
> >> is more compatible with GNU.
>
> I gather that it should be applied to the stable and development
> branch. Right?
That would be ideal from my perspective, yes.
> >> I’ve tested this (somewhat superficially) with XEmacs 21.5, 21.4
> >> and GNU.
>
> (Just call the later "Emacs".)
That’s something I’ve considered, yes. (Also, “latter”.)
> >> Please advise me if this is the wrong list to submit this to.
>
> It's the right list. Thanks.
>
> >> I have papers on file with the FSF for Gnus and for GNU Emacs as a
> >> whole, so that shouldn’t be an issue.
>
> Confirmed.
>
> >> * gnus-util.el (gnus-put-display-table): New.
> >> (gnus-get-display-table): New.
> >> Macros that expand to an #'aset call under GNU, and to a runtime choice
> >> under XEmacs.
>
> Is writing “#'” a new XEmacsy ChangeLog convention?
No, it’s a Common Lisp thing that I picked up from the SXEmacs folk, and
that I find helpful and clear. (In CL it’s a macro that throws an error at
read time if the following symbol doesn’t have a function definition.)
> >> * gnus-sum.el (gnus-summary-set-display-table):
> >> Use #'gnus-{put,get}-display-table, gnus-set-display-table for the
> >> display table, instead of #'aset.
> >> * gnus-xmas.el (gnus-xmas-summary-set-display-table):
> >> Use #'gnus-{put,get}-display-table, gnus-set-display-table for the
> >> display table.
>
> It's better (e.g. for searching) to spell out the macro names (not
> using {put,get}).
This is unclear to me; are you asking me to resubmit the patch for this
reason?
> >> ＠＠ -3431,8 +3431,8 ＠＠
> >> 256)))
> >> (while (>= (setq i (1- i)) 127)
> >> ;; Only modify if the entry is nil.
> >> - (unless (aref table i)
> >> - (aset table i [??]))))
> >> + (unless (get-display-table i table)
> >> + (put-display-table i [??] table))))
> >> (setq buffer-display-table table)))
> >
> > Should those be `gnus-get-display-table' and `gnus-put-display-table'?
>
> Aidan?
Ah, yes, they should. I’ll resubmit the patch on that basis.
> >> +(defmacro gnus-put-display-table (range value display-table)
> >> + "Set the value for char RANGE to VALUE in DISPLAY-TABLE. "
> >> + (if (featurep 'xemacs)
> >> + (progn
>
> Useless `progn'?
Yes.
> >> + `(if (fboundp 'put-display-table)
> >> + (put-display-table ,range ,value ,display-table)
> >> + (if (sequencep ,display-table)
> >> + (aset ,display-table ,range ,value)
> >> + (put-char-table ,range ,value ,display-table))))
>
> `cond' would be more readable than an `if'-cascade, IMHO.
Meh, part of the cascade is at compile time, part at run time, and the
latter is only two deep. One more level and I would agree with you.
--
¿Dónde estará ahora mi sobrino Yoghurtu Nghé, que tuvo que huir
precipitadamente de la aldea por culpa de la escasez de rinocerontes?
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://calypso.tux.org/cgi-bin/mailman/listinfo/xemacs-patches
- 1 participants
- 1 comments
[COMMIT] Don't load .flc files from the directory of the corresponding file
16 years, 11 months
Aidan Kehoe
Aidan Kehoe
Ville, I’ve tested this, and it works. Norbert, you’re away for the next
couple of weeks; does anyone else have access to build and release a new
package?
APPROVE COMMIT
NOTE: This patch has been committed.
xemacs-packages/edit-utils/ChangeLog addition:
2008-06-09 Aidan Kehoe <kehoea(a)parhasard.net>
* fast-lock.el (fast-lock-cache-directories):
Remove the directory the file is in, to avoid running code from
arbitrary other users. Update the docstring to motivate this.
Also, mark it as a risky local variable to prevent it being
evaluated in file local variable sections.
Thank you Ulrich Müller, thank you Hans de Graaff.
XEmacs Packages source patch:
Diff command: cvs -q diff -Nu
Files affected: xemacs-packages/edit-utils/fast-lock.el
===================================================================
RCS
Index: xemacs-packages/edit-utils/fast-lock.el
===================================================================
RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/edit-utils/fast-lock.el,v
retrieving revision 1.4
diff -u -u -r1.4 fast-lock.el
--- xemacs-packages/edit-utils/fast-lock.el 2006/03/07 07:10:32 1.4
+++ xemacs-packages/edit-utils/fast-lock.el 2008/06/09 18:55:05
＠＠ -247,7 +247,7 ＠＠
;; User Variables:
-(defcustom fast-lock-cache-directories '("." "~/.emacs-flc")
+(defcustom fast-lock-cache-directories '("~/.emacs-flc")
; - `internal', keep each file's Font Lock cache file in the same file.
; - `external', keep each file's Font Lock cache file in the same directory.
"*Directories in which Font Lock cache files are saved and read.
＠＠ -265,9 +265,14 ＠＠
((\"^/your/true/home/directory/\" . \".\") \"~/.emacs-flc\")
would cause a file's current directory to be used if the file is under your
-home directory hierarchy, or otherwise the absolute directory `~/.emacs-flc'."
+home directory hierarchy, or otherwise the absolute directory `~/.emacs-flc'.
+For security reasons, it is not advisable to use the file's current directory
+to avoid the possibility of using the cache of another user."
:type '(repeat (choice (cons regexp directory) directory))
:group 'fast-lock)
+
+;;;###autoload
+(put 'fast-lock-cache-directories 'risky-local-variable t)
(defcustom fast-lock-minimum-size (* 25 1024)
"*Minimum size of a buffer for cached fontification.
--
¿Dónde estará ahora mi sobrino Yoghurtu Nghé, que tuvo que huir
precipitadamente de la aldea por culpa de la escasez de rinocerontes?
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://calypso.tux.org/cgi-bin/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
Re: [Bug: 21.5-b28] lines in occur-engine wasn't correctly computed
16 years, 11 months
FKtPp
FKtPp
On Thu, May 29, 2008 at 12:14:51AM +0800, It's me FKtPp ;) wrote:
> ================================================================
> Dear Bug Team!
>
> When occuring some regexp, which can match across multi-lines, line
> numbers in the occur result list will be incorrectly computed.
>
> (setq origpt (point))
> (when (setq endpt (re-search-forward regexp nil t))
> (setq matches (1+ matches)) ;; increment match count
> (setq matchbeg (match-beginning 0))
> (setq lines (+ lines (1- (count-lines origpt endpt))))
>
> Note that endpt, it was not at the same line of the "diplayed string
> in the occur result list" in case of multi-line match.
>
> ================================================================
>
hi Team,
I've composed a patch against this issue, could you please help
evaluate it. And if possiable install it?
ChangeLog Entry:
===============================================================================
2008-06-09 It's me FKtPp ;) <m_pupil(a)yahoo.com.cn>
* occur.el:
* occur.el (occur-accumulate-lines): Convert to use
#'point-at-b(e)ol built-in functions
* occur.el (occur-engine-update-lines): New. always count lines
from a bol to anther bol
* occur.el (occur-engine): change the lines value calculation
method, so that it can deal with multine matches,
e.g. `^(def[^()]+)'. Mainly because of the following lines in the
(info "(lispref)Syntax of Regexps").
Note that a complement character set can match a newline, unless
newline is mentioned as one of the characters not to match.
Patch Entry:
===============================================================================
core-beta[XEmacs] source patch:
Diff command: hg diff -wbB
Files affected: lisp/occur.el
diff -r 0204391fc17c lisp/occur.el
--- lisp/occur.el Wed Jun 04 21:57:49 2008 +0200
+++ lisp/occur.el Mon Jun 09 02:30:24 2008 +0800
＠＠ -246,8 +246,9 ＠＠
(eobp)
(bobp))))
(setq count (+ count (if forwardp -1 1)))
- (setq beg (line-beginning-position)
- end (line-end-position))
+ ;; XEmacs specific line-beginning/end-possion to point-at-b(e)ol conversion
+ (setq beg (point-at-bol)
+ end (point-at-eol))
(if (and keep-props (if-boundp 'jit-lock-mode jit-lock-mode)
(text-property-not-all beg end 'fontified t))
(if-fboundp 'jit-lock-fontify-now
＠＠ -426,6 +427,19 ＠＠
(concat " :" line "\n"))
lines))
+(defsubst occur-engine-update-lines (lines beg end)
+ "count lines between the BEG and END point position, then add to LINES
+
+Returns updated LINES value.
+NOTE: this is a XEmacs specific inline function."
+ (save-excursion
+ (let (beg-bol end-bol)
+ (goto-char beg)
+ (setq beg-bol (point-at-bol))
+ (goto-char end)
+ (setq end-bol (point-at-bol))
+ (+ lines (count-lines beg-bol end-bol)))))
+
(defun occur-engine (regexp buffers out-buf nlines case-fold-search
title-face prefix-face match-face keep-props)
(with-current-buffer out-buf
＠＠ -456,83 +470,96 ＠＠
(goto-char (point-min)) ;; begin searching in the buffer
(while (not (eobp))
(setq origpt (point))
- (when (setq endpt (re-search-forward regexp nil t))
- (setq matches (1+ matches)) ;; increment match count
- (setq matchbeg (match-beginning 0))
- (setq lines (+ lines (1- (count-lines origpt endpt))))
- (save-excursion
- (goto-char matchbeg)
- (setq begpt (line-beginning-position)
- endpt (line-end-position)))
- (setq marker (make-marker))
- (set-marker marker matchbeg)
- (if (and keep-props
- (if-boundp 'jit-lock-mode jit-lock-mode)
- (text-property-not-all begpt endpt 'fontified t))
- (if-fboundp #'jit-lock-fontify-now
- (jit-lock-fontify-now begpt endpt)))
- (setq curstring (buffer-substring begpt endpt))
- ;; Depropertize the string, and maybe
- ;; highlight the matches
- (let ((len (length curstring))
- (start 0))
- (unless keep-props
- (set-text-properties 0 len nil curstring))
- (while (and (< start len)
- (string-match regexp curstring start))
- (add-text-properties
- (match-beginning 0) (match-end 0)
- (append
- `(occur-match t)
- (when match-face
- ;; Use `face' rather than `font-lock-face' here
- ;; so as to override faces copied from the buffer.
- `(face ,match-face)))
- curstring)
- (setq start (match-end 0))))
- ;; Generate the string to insert for this match
- (let* ((out-line
- (concat
- ;; Using 7 digits aligns tabs properly.
- (apply #'propertize (format "%7d:" lines)
- (append
- (when prefix-face
- `(font-lock-face prefix-face))
- '(occur-prefix t)))
- ;; We don't put `mouse-face' on the newline,
- ;; because that loses. And don't put it
- ;; on context lines to reduce flicker.
- (propertize curstring 'mouse-face 'highlight)
- "\n"))
- (data
- (if (= nlines 0)
- ;; The simple display style
- out-line
- ;; The complex multi-line display
- ;; style. Generate a list of lines,
- ;; concatenate them all together.
- (apply #'concat
- (nconc
- (occur-engine-add-prefix (nreverse (cdr (occur-accumulate-lines (- (1+ (abs nlines))) keep-props))))
- (list out-line)
- (if (> nlines 0)
- (occur-engine-add-prefix
- (cdr (occur-accumulate-lines (1+ nlines) keep-props)))))))))
- ;; Actually insert the match display data
- (with-current-buffer out-buf
- (let ((beg (point))
- (end (progn (insert data) (point))))
- (unless (= nlines 0)
- (insert "-------\n"))
- (add-text-properties
- beg end
- `(occur-target ,marker help-echo "mouse-2: go to this occurrence")))))
- (goto-char endpt))
- (if endpt
- (progn
- (setq lines (1+ lines))
- ;; On to the next match...
- (forward-line 1))
+ (if (setq endpt (re-search-forward regexp nil t))
+ (progn (setq matches (1+ matches) ;; increment match count
+ matchbeg (match-beginning 0)
+ matchend endpt
+ ;; Yes, always count against the
+ ;; matchbeg to keep the lines value
+ ;; correct
+ lines (occur-engine-update-lines lines origpt matchbeg))
+ ;; Later the #'occur-accumulate-lines
+ ;; function will relays current POINT
+ ;; position to extract correct result, so
+ ;; we don't do #'save-excursion here
+ ;; anymore.
+ (goto-char matchbeg)
+ ;; XEmacs specific
+ ;; line-beginning/end-possion to
+ ;; point-at-b(e)ol conversion.
+ (setq begpt (point-at-bol)
+ endpt (point-at-eol))
+ (setq marker (make-marker))
+ (set-marker marker matchbeg)
+ (if (and keep-props
+ (if-boundp 'jit-lock-mode jit-lock-mode)
+ (text-property-not-all begpt endpt 'fontified t))
+ (if-fboundp #'jit-lock-fontify-now
+ (jit-lock-fontify-now begpt endpt)))
+ (setq curstring (buffer-substring begpt endpt))
+ ;; Depropertize the string, and maybe
+ ;; highlight the matches
+ (let ((len (length curstring))
+ (start 0))
+ (unless keep-props
+ (set-text-properties 0 len nil curstring))
+ (while (and (< start len)
+ (string-match regexp curstring start))
+ (add-text-properties
+ (match-beginning 0) (match-end 0)
+ (append
+ `(occur-match t)
+ (when match-face
+ ;; Use `face' rather than `font-lock-face' here
+ ;; so as to override faces copied from the buffer.
+ `(face ,match-face)))
+ curstring)
+ (setq start (match-end 0))))
+ ;; Generate the string to insert for this match
+ (let* ((out-line
+ (concat
+ ;; Using 7 digits aligns tabs properly.
+ (apply #'propertize (format "%7d:" lines)
+ (append
+ (when prefix-face
+ `(font-lock-face prefix-face))
+ '(occur-prefix t)))
+ ;; We don't put `mouse-face' on the newline,
+ ;; because that loses. And don't put it
+ ;; on context lines to reduce flicker.
+ (propertize curstring 'mouse-face 'highlight)
+ "\n"))
+ (data
+ (if (= nlines 0)
+ ;; The simple display style
+ out-line
+ ;; The complex multi-line display
+ ;; style. Generate a list of lines,
+ ;; concatenate them all together.
+ (apply #'concat
+ (nconc
+ (occur-engine-add-prefix (nreverse (cdr (occur-accumulate-lines (- (1+ (abs nlines))) keep-props))))
+ (list out-line)
+ (if (> nlines 0)
+ (occur-engine-add-prefix
+ (cdr (occur-accumulate-lines (1+ nlines) keep-props)))))))))
+ ;; Actually insert the match display data
+ (with-current-buffer out-buf
+ (let ((beg (point))
+ (end (progn (insert data) (point))))
+ (unless (= nlines 0)
+ (insert "-------\n"))
+ (add-text-properties
+ beg end
+ `(occur-target ,marker help-echo "mouse-2: go to this occurrence")))))
+ ;; On to the next match... Here we don't
+ ;; do the ugly #'forward-line and #'1+
+ ;; lines, instead calculate the actual
+ ;; lines between the matchbeg and
+ ;; matchend so that it can deal with
+ ;; multi-line matches.
+ (goto-char matchend)
+ (setq lines (occur-engine-update-lines lines matchbeg matchend)))
(goto-char (point-max))))))
(when (not (zerop matches)) ;; is the count zero?
(setq globalcount (+ globalcount matches))
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://calypso.tux.org/cgi-bin/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
carbon2-commit: #'require hyper-apropos in #'describe-property-list, for hyper-apropos-face
16 years, 11 months
Aidan Kehoe
Aidan Kehoe
changeset: 4502:0204391fc17cfbae2117a6ba5babd84081ac3834
user: Aidan Kehoe <kehoea(a)parhasard.net>
date: Wed Jun 04 21:57:49 2008 +0200
files: lisp/ChangeLog lisp/descr-text.el
description:
#'require hyper-apropos in #'describe-property-list, for hyper-apropos-face
2008-06-04 Aidan Kehoe <kehoea(a)parhasard.net>
* descr-text.el (describe-property-list):
#'require hyper-apropos, since we use hyper-apropos-face
diff -r a99eb40f0b5b20b5883afae4908bf425998addbf -r 0204391fc17cfbae2117a6ba5babd84081ac3834 lisp/ChangeLog
--- a/lisp/ChangeLog Thu May 29 18:53:45 2008 +0200
+++ b/lisp/ChangeLog Wed Jun 04 21:57:49 2008 +0200
＠＠ -1,3 +1,8 ＠＠ 2008-05-25 Aidan Kehoe <kehoea＠parhasa
+2008-06-04 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * descr-text.el (describe-property-list):
+ #'require hyper-apropos, since we use hyper-apropos-face
+
2008-05-25 Aidan Kehoe <kehoea(a)parhasard.net>
* descr-text.el: New.
diff -r a99eb40f0b5b20b5883afae4908bf425998addbf -r 0204391fc17cfbae2117a6ba5babd84081ac3834 lisp/descr-text.el
--- a/lisp/descr-text.el Thu May 29 18:53:45 2008 +0200
+++ b/lisp/descr-text.el Wed Jun 04 21:57:49 2008 +0200
＠＠ -82,6 +82,7 ＠＠ into help buttons that call `describe-te
into help buttons that call `describe-text-category' or
`describe-face' when pushed."
;; Sort the properties by the size of their value.
+ (require 'hyper-apropos)
(dolist (elt (sort (let (ret)
(while properties
(push (list (pop properties) (pop properties)) ret))
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://calypso.tux.org/cgi-bin/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
carbon2-commit: Correct an omitted word, expand on bignum equality in the lispref.
16 years, 11 months
Aidan Kehoe
Aidan Kehoe
changeset: 4501:a99eb40f0b5b20b5883afae4908bf425998addbf
user: Aidan Kehoe <kehoea(a)parhasard.net>
date: Thu May 29 18:53:45 2008 +0200
files: man/ChangeLog man/lispref/objects.texi
description:
Correct an omitted word, expand on bignum equality in the lispref.
2008-05-29 Aidan Kehoe <kehoea(a)parhasard.net>
* lispref/objects.texi (Equality Predicates):
Expand on bignum equality; correct an omitted word in the last
commit.
diff -r 2d39535e1f9d3557a3382ef0823ad5a47ace5a6a -r a99eb40f0b5b20b5883afae4908bf425998addbf man/ChangeLog
--- a/man/ChangeLog Tue May 27 11:58:42 2008 +0200
+++ b/man/ChangeLog Thu May 29 18:53:45 2008 +0200
＠＠ -1,3 +1,9 ＠＠ 2008-05-27 Aidan Kehoe <kehoea＠parhasa
+2008-05-29 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * lispref/objects.texi (Equality Predicates):
+ Expand on bignum equality; correct an omitted word in the last
+ commit.
+
2008-05-27 Aidan Kehoe <kehoea(a)parhasard.net>
* lispref/objects.texi (Equality Predicates):
diff -r 2d39535e1f9d3557a3382ef0823ad5a47ace5a6a -r a99eb40f0b5b20b5883afae4908bf425998addbf man/lispref/objects.texi
--- a/man/lispref/objects.texi Tue May 27 11:58:42 2008 +0200
+++ b/man/lispref/objects.texi Thu May 29 18:53:45 2008 +0200
＠＠ -2247,10 +2247,12 ＠＠ change in one will be reflected by the s
＠code{eq} returns ＠code{t} if ＠var{object1} and ＠var{object2} are
integers with the same value. It is preferable to use ＠code{=} or
-＠code{eql} in many contexts for numeric comparison; ＠pxref{Comparison of
-Numbers}. ＠code{eq} also returns ＠code{t} if ＠var{object1} and
-＠var{object2} are identical characters, though in this case you may
-prefer to use ＠code{char=}.
+＠code{eql} in many contexts for numeric comparison, especially since
+bignums (integers with values that would have otherwise overflowed, only
+available on some builds) with the same value are not ＠code{eq};
+＠pxref{Comparison of Numbers}. ＠code{eq} also returns ＠code{t} if
+＠var{object1} and ＠var{object2} are identical characters, though in this
+case you may prefer to use ＠code{char=}.
Also, since symbol names are normally unique, if the arguments are
symbols with the same name, they are ＠code{eq}. For other types (e.g.,
＠＠ -2264,7 +2266,7 ＠＠ the same name are not ＠code{eq}. ＠xref{
the same name are not ＠code{eq}. ＠xref{Creating Symbols}.)
NOTE: Under XEmacs 19, characters are really just integers, and thus
-characters and integers with the same numeric are ＠code{eq}. Under
+characters and integers with the same numeric code are ＠code{eq}. Under
XEmacs 20, it was necessary to preserve remnants of this in function
such as ＠code{old-eq} in order to maintain byte-code compatibility.
Byte code compiled under any Emacs 19 will automatically have calls to
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://calypso.tux.org/cgi-bin/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
carbon2-commit: Correct a thinko in the #'translate-region docstring
16 years, 11 months
Aidan Kehoe
Aidan Kehoe
changeset: 4499:c76b1bc6bd28adf5c762d5575a55b9ac49dddc7b
user: Aidan Kehoe <kehoea(a)parhasard.net>
date: Tue May 27 12:01:29 2008 +0200
files: src/ChangeLog src/editfns.c
description:
Correct a thinko in the #'translate-region docstring
2008-05-27 Aidan Kehoe <kehoea(a)parhasard.net>
* editfns.c (Ftranslate_region):
Correct a thinko in the last commit; I meant #'get-char-table, not
#'put-char-table.
diff -r c661944aa2597457798ce30bdaa6ac6ddbc8c3b0 -r c76b1bc6bd28adf5c762d5575a55b9ac49dddc7b src/ChangeLog
--- a/src/ChangeLog Sun May 25 22:54:33 2008 +0200
+++ b/src/ChangeLog Tue May 27 12:01:29 2008 +0200
＠＠ -1,3 +1,9 ＠＠ 2008-05-25 Aidan Kehoe <kehoea＠parhasa
+2008-05-27 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * editfns.c (Ftranslate_region):
+ Correct a thinko in the last commit; I meant #'get-char-table, not
+ #'put-char-table.
+
2008-05-25 Aidan Kehoe <kehoea(a)parhasard.net>
* chartab.c (Fmake_char_table):
diff -r c661944aa2597457798ce30bdaa6ac6ddbc8c3b0 -r c76b1bc6bd28adf5c762d5575a55b9ac49dddc7b src/editfns.c
--- a/src/editfns.c Sun May 25 22:54:33 2008 +0200
+++ b/src/editfns.c Tue May 27 12:01:29 2008 +0200
＠＠ -1825,11 +1825,11 ＠＠ nil (nil meaning don't replace.)
If TABLE is a char-table, its elements describe the mapping between
characters and their replacements. The char-table should be of type `char'
-or `generic'. If the value given by `put-char-table' for a given character
+or `generic'. If the value given by `get-char-table' for a given character
is nil, that character will not be translated by `translate-region'. Since
-`char' char-tables can never return nil to `put-char-table', and since most
-translation involves a subset of the possible XEmacs characters, not all of
-them, the most generally useful table type here is `generic'.
+`get-char-table' can never return nil with a char table of type `char', and
+since most translation involves a subset of the possible XEmacs characters,
+not all of them, the most generally useful table type here is `generic'.
Returns the number of substitutions performed.
*/
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://calypso.tux.org/cgi-bin/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
carbon2-commit: Say explicitly that eq is useful for chars; xref number comparison, lispref
16 years, 11 months
Aidan Kehoe
Aidan Kehoe
changeset: 4500:2d39535e1f9d3557a3382ef0823ad5a47ace5a6a
user: Aidan Kehoe <kehoea(a)parhasard.net>
date: Tue May 27 11:58:42 2008 +0200
files: man/ChangeLog man/lispref/objects.texi
description:
Say explicitly that eq is useful for chars; xref number comparison, lispref
2008-05-27 Aidan Kehoe <kehoea(a)parhasard.net>
* lispref/objects.texi (Equality Predicates):
Cross reference to the section on comparison of numbers when
talking about using #'eq with integers; also mention that
#'eq gives t when passed identical integers, and that #'char= is
also available there.
diff -r c76b1bc6bd28adf5c762d5575a55b9ac49dddc7b -r 2d39535e1f9d3557a3382ef0823ad5a47ace5a6a man/ChangeLog
--- a/man/ChangeLog Tue May 27 12:01:29 2008 +0200
+++ b/man/ChangeLog Tue May 27 11:58:42 2008 +0200
＠＠ -1,3 +1,11 ＠＠ 2008-05-21 Aidan Kehoe <kehoea＠parhasa
+2008-05-27 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * lispref/objects.texi (Equality Predicates):
+ Cross reference to the section on comparison of numbers when
+ talking about using #'eq with integers; also mention that
+ #'eq gives t when passed identical integers, and that #'char= is
+ also available there.
+
2008-05-21 Aidan Kehoe <kehoea(a)parhasard.net>
* internals/internals.texi (Ben's README):
diff -r c76b1bc6bd28adf5c762d5575a55b9ac49dddc7b -r 2d39535e1f9d3557a3382ef0823ad5a47ace5a6a man/lispref/objects.texi
--- a/man/lispref/objects.texi Tue May 27 12:01:29 2008 +0200
+++ b/man/lispref/objects.texi Tue May 27 11:58:42 2008 +0200
＠＠ -2246,12 +2246,17 ＠＠ change in one will be reflected by the s
change in one will be reflected by the same change in the other.
＠code{eq} returns ＠code{t} if ＠var{object1} and ＠var{object2} are
-integers with the same value. Also, since symbol names are normally
-unique, if the arguments are symbols with the same name, they are
-＠code{eq}. For other types (e.g., lists, vectors, strings), two
-arguments with the same contents or elements are not necessarily
-＠code{eq} to each other: they are ＠code{eq} only if they are the same
-object.
+integers with the same value. It is preferable to use ＠code{=} or
+＠code{eql} in many contexts for numeric comparison; ＠pxref{Comparison of
+Numbers}. ＠code{eq} also returns ＠code{t} if ＠var{object1} and
+＠var{object2} are identical characters, though in this case you may
+prefer to use ＠code{char=}.
+
+Also, since symbol names are normally unique, if the arguments are
+symbols with the same name, they are ＠code{eq}. For other types (e.g.,
+lists, vectors, strings), two arguments with the same contents or
+elements are not necessarily ＠code{eq} to each other: they are ＠code{eq}
+only if they are the same object.
(The ＠code{make-symbol} function returns an uninterned symbol that is
not interned in the standard ＠code{obarray}. When uninterned symbols
＠＠ -2259,11 +2264,11 ＠＠ the same name are not ＠code{eq}. ＠xref{
the same name are not ＠code{eq}. ＠xref{Creating Symbols}.)
NOTE: Under XEmacs 19, characters are really just integers, and thus
-characters and integers are ＠code{eq}. Under XEmacs 20, it was
-necessary to preserve remnants of this in function such as ＠code{old-eq}
-in order to maintain byte-code compatibility. Byte code compiled
-under any Emacs 19 will automatically have calls to ＠code{eq} mapped
-to ＠code{old-eq} when executed under XEmacs 20.
+characters and integers with the same numeric are ＠code{eq}. Under
+XEmacs 20, it was necessary to preserve remnants of this in function
+such as ＠code{old-eq} in order to maintain byte-code compatibility.
+Byte code compiled under any Emacs 19 will automatically have calls to
+＠code{eq} mapped to ＠code{old-eq} when executed under XEmacs 20.
＠example
＠group
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://calypso.tux.org/cgi-bin/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
carbon2-commit: Fill out docstrings for #'translate-region, #'make-char-table.
16 years, 11 months
Aidan Kehoe
Aidan Kehoe
changeset: 4498:c661944aa2597457798ce30bdaa6ac6ddbc8c3b0
user: Aidan Kehoe <kehoea(a)parhasard.net>
date: Sun May 25 22:54:33 2008 +0200
files: src/ChangeLog src/chartab.c src/editfns.c
description:
Fill out docstrings for #'translate-region, #'make-char-table.
2008-05-25 Aidan Kehoe <kehoea(a)parhasard.net>
* chartab.c (Fmake_char_table):
Document the default return values for the various char table
types.
* editfns.c (Ftranslate_region): Document why `generic' char tables
are preferable to `char' char tables for this function.
diff -r a78d697ccd2c832f5770b564e944a88b4f1f2549 -r c661944aa2597457798ce30bdaa6ac6ddbc8c3b0 src/ChangeLog
--- a/src/ChangeLog Sun May 25 21:11:35 2008 +0200
+++ b/src/ChangeLog Sun May 25 22:54:33 2008 +0200
＠＠ -1,3 +1,11 ＠＠ 2008-05-21 Aidan Kehoe <kehoea＠parhasa
+2008-05-25 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * chartab.c (Fmake_char_table):
+ Document the default return values for the various char table
+ types.
+ * editfns.c (Ftranslate_region): Document why `generic' char tables
+ are preferable to `char' char tables for this function.
+
2008-05-21 Aidan Kehoe <kehoea(a)parhasard.net>
* fileio.c (Fmake_symbolic_link):
diff -r a78d697ccd2c832f5770b564e944a88b4f1f2549 -r c661944aa2597457798ce30bdaa6ac6ddbc8c3b0 src/chartab.c
--- a/src/chartab.c Sun May 25 21:11:35 2008 +0200
+++ b/src/chartab.c Sun May 25 22:54:33 2008 +0200
＠＠ -566,25 +566,32 ＠＠ sorts of values. The different char tab
sorts of values. The different char table types are
`category'
- Used for category tables, which specify the regexp categories
- that a character is in. The valid values are nil or a
- bit vector of 95 elements. Higher-level Lisp functions are
- provided for working with category tables. Currently categories
+ Used for category tables, which specify the regexp categories that a
+ character is in. The valid values are nil or a bit vector of 95
+ elements, and values default to nil. Higher-level Lisp functions
+ are provided for working with category tables. Currently categories
and category tables only exist when Mule support is present.
`char'
- A generalized char table, for mapping from one character to
- another. Used for case tables, syntax matching tables,
- `keyboard-translate-table', etc. The valid values are characters.
+ A generalized char table, for mapping from one character to another.
+ Used for case tables, syntax matching tables,
+ `keyboard-translate-table', etc. The valid values are characters,
+ and the default result given by `get-char-table' if a value hasn't
+ been set for a given character or for a range that includes it, is
+ ?\x00.
`generic'
- An even more generalized char table, for mapping from a
- character to anything.
+ An even more generalized char table, for mapping from a character to
+ anything. The default result given by `get-char-table' is nil.
`display'
- Used for display tables, which specify how a particular character
- is to appear when displayed. #### Not yet implemented.
+ Used for display tables, which specify how a particular character is
+ to appear when displayed. #### Not yet implemented; currently, the
+ display table code uses generic char tables, and it's not clear that
+ implementing this char table type would be useful.
`syntax'
Used for syntax tables, which specify the syntax of a particular
character. Higher-level Lisp functions are provided for
- working with syntax tables. The valid values are integers.
+ working with syntax tables. The valid values are integers, and the
+ default result given by `get-char-table' is the syntax code for
+ `inherit'.
*/
(type))
{
diff -r a78d697ccd2c832f5770b564e944a88b4f1f2549 -r c661944aa2597457798ce30bdaa6ac6ddbc8c3b0 src/editfns.c
--- a/src/editfns.c Sun May 25 21:11:35 2008 +0200
+++ b/src/editfns.c Sun May 25 22:54:33 2008 +0200
＠＠ -1824,8 +1824,12 ＠＠ nil (nil meaning don't replace.)
nil (nil meaning don't replace.)
If TABLE is a char-table, its elements describe the mapping between
-characters and their replacements. The char-table should be of type
-`char' or `generic'.
+characters and their replacements. The char-table should be of type `char'
+or `generic'. If the value given by `put-char-table' for a given character
+is nil, that character will not be translated by `translate-region'. Since
+`char' char-tables can never return nil to `put-char-table', and since most
+translation involves a subset of the possible XEmacs characters, not all of
+them, the most generally useful table type here is `generic'.
Returns the number of substitutions performed.
*/
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://calypso.tux.org/cgi-bin/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
carbon2-commit: Import and extend GNU's descr-text.el, supporting prefix argument for C-x =
16 years, 11 months
Aidan Kehoe
Aidan Kehoe
changeset: 4497:a78d697ccd2c832f5770b564e944a88b4f1f2549
parent: 4493:23ef20edf6ba892a78e7e257a28f4879e31f4095
user: Aidan Kehoe <kehoea(a)parhasard.net>
date: Sun May 25 21:11:35 2008 +0200
files: lisp/ChangeLog lisp/descr-text.el lisp/mule/mule-cmds.el lisp/simple.el lisp/syntax.el lisp/unicode.el
description:
Import and extend GNU's descr-text.el, supporting prefix argument for C-x =
2008-05-25 Aidan Kehoe <kehoea(a)parhasard.net>
* descr-text.el: New.
Taken from GNU's GPLV2 version of 2007-02-14, with modifications
for XEmacs support and extensions for Unihan.txt support and
db/dbm caches.
* simple.el (what-cursor-position):
Support an optional prefix argument, as does GNU, calling
#'describe-char to giving more detail on the character at point,
notably from UnicodeData and (in our case, optionally) Unihan.txt.
* syntax.el (syntax-after):
Make this available for the sake of #'describe-char.
* mule/mule-cmds.el (iso-2022-control-alist):
Make this available, for the sake of #'encoded-string-description
and #'describe-char.
* mule/mule-cmds.el (encoded-string-description):
Make this available, for the sake of #'describe-char.
* unicode.el (unicode-error-default-translation-table):
Make this a char table of type generic, not of type char. Makes it
possible to have the relevant logic in #'describe-char reasonably
clear; also, and this is undocumented, makes it much easier to
implement #'frob-unicode-errors-region. I should document this,
and revise #'frob-unicode-errors-region.
diff -r 23ef20edf6ba892a78e7e257a28f4879e31f4095 -r a78d697ccd2c832f5770b564e944a88b4f1f2549 lisp/ChangeLog
--- a/lisp/ChangeLog Wed May 21 21:09:20 2008 +0200
+++ b/lisp/ChangeLog Sun May 25 21:11:35 2008 +0200
＠＠ -1,3 +1,27 ＠＠ 2008-05-14 Stephen J. Turnbull <stephe
+2008-05-25 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * descr-text.el: New.
+ Taken from GNU's GPLV2 version of 2007-02-14, with modifications
+ for XEmacs support and extensions for Unihan.txt support and
+ db/dbm caches.
+ * simple.el (what-cursor-position):
+ Support an optional prefix argument, as does GNU, calling
+ #'describe-char to giving more detail on the character at point,
+ notably from UnicodeData and (in our case, optionally) Unihan.txt.
+ * syntax.el (syntax-after):
+ Make this available for the sake of #'describe-char.
+ * mule/mule-cmds.el (iso-2022-control-alist):
+ Make this available, for the sake of #'encoded-string-description
+ and #'describe-char.
+ * mule/mule-cmds.el (encoded-string-description):
+ Make this available, for the sake of #'describe-char.
+ * unicode.el (unicode-error-default-translation-table):
+ Make this a char table of type generic, not of type char. Makes it
+ possible to have the relevant logic in #'describe-char reasonably
+ clear; also, and this is undocumented, makes it much easier to
+ implement #'frob-unicode-errors-region. I should document this,
+ and revise #'frob-unicode-errors-region.
+
2008-05-14 Stephen J. Turnbull <stephen(a)xemacs.org>
* subr.el (add-to-list): Fix Aidan's last commit.
diff -r 23ef20edf6ba892a78e7e257a28f4879e31f4095 -r a78d697ccd2c832f5770b564e944a88b4f1f2549 lisp/mule/mule-cmds.el
--- a/lisp/mule/mule-cmds.el Wed May 21 21:09:20 2008 +0200
+++ b/lisp/mule/mule-cmds.el Sun May 25 21:11:35 2008 +0200
＠＠ -901,34 +901,24 ＠＠ It can be retrieved with `(get-char-code
;; Pretty description of encoded string
;; Alist of ISO 2022 control code vs the corresponding mnemonic string.
-;; (defvar iso-2022-control-alist
-;; '((?\x1b . "ESC")
-;; (?\x0e . "SO")
-;; (?\x0f . "SI")
-;; (?\x8e . "SS2")
-;; (?\x8f . "SS3")
-;; (?\x9b . "CSI")))
-
-;; (defun encoded-string-description (str coding-system)
-;; "Return a pretty description of STR that is encoded by CODING-SYSTEM."
-;; (setq str (string-as-unibyte str))
-;; (let ((char (aref str 0))
-;; desc)
-;; (when (< char 128)
-;; (setq desc (or (cdr (assq char iso-2022-control-alist))
-;; (char-to-string char)))
-;; (let ((i 1)
-;; (len (length str)))
-;; (while (< i len)
-;; (setq char (aref str i))
-;; (if (>= char 128)
-;; (setq desc nil i len)
-;; (setq desc (concat desc " "
-;; (or (cdr (assq char iso-2022-control-alist))
-;; (char-to-string char)))
-;; i (1+ i))))))
-;; (or desc
-;; (mapconcat (function (lambda (x) (format "0x%02x" x))) str " "))))
+(defvar iso-2022-control-alist
+ '((?\x1b . "ESC")
+ (?\x0e . "SO")
+ (?\x0f . "SI")
+ (?\x8e . "SS2")
+ (?\x8f . "SS3")
+ (?\x9b . "CSI")))
+
+(defun encoded-string-description (str coding-system)
+ "Return a pretty description of STR that is encoded by CODING-SYSTEM."
+; (setq str (string-as-unibyte str))
+ (mapconcat
+ (if (and coding-system (eq (coding-system-type coding-system) 'iso2022))
+ ;; Try to get a pretty description for ISO 2022 escape sequences.
+ (function (lambda (x) (or (cdr (assq x iso-2022-control-alist))
+ (format "#x%02X" x))))
+ (function (lambda (x) (format "#x%02X" x))))
+ str " "))
;; (defun encode-coding-char (char coding-system)
;; "Encode CHAR by CODING-SYSTEM and return the resulting string.
diff -r 23ef20edf6ba892a78e7e257a28f4879e31f4095 -r a78d697ccd2c832f5770b564e944a88b4f1f2549 lisp/simple.el
--- a/lisp/simple.el Wed May 21 21:09:20 2008 +0200
+++ b/lisp/simple.el Sun May 25 21:11:35 2008 +0200
＠＠ -782,13 +782,16 ＠＠ See also `line-number'."
done)))
(- (buffer-size) (forward-line (buffer-size)))))))
-(defun what-cursor-position ()
+(defun what-cursor-position (&optional detail)
"Print info on cursor position (on screen and within buffer).
Also describe the character after point, giving its UCS code point and Mule
charset and codes; for ASCII characters, give its code in octal, decimal and
-hex."
- ;; XEmacs change
- (interactive "_")
+hex.
+
+With prefix argument, show extended details about the character in a
+separate buffer. See also the command `describe-char'."
+ ;; XEmacs change "_"
+ (interactive "_P")
(let* ((char (char-after (point))) ; XEmacs
(beg (point-min))
(end (point-max))
＠＠ -813,6 +816,8 ＠＠ hex."
(if (= pos end)
(message "point=%d of %d(%d%%)%s column %d %s"
pos total percent narrowed-details col hscroll)
+ (if detail
+ (describe-char (point)))
;; XEmacs: don't use single-key-description, treat non-ASCII
;; characters differently.
(if (< char ?\x80)
diff -r 23ef20edf6ba892a78e7e257a28f4879e31f4095 -r a78d697ccd2c832f5770b564e944a88b4f1f2549 lisp/syntax.el
--- a/lisp/syntax.el Wed May 21 21:09:20 2008 +0200
+++ b/lisp/syntax.el Sun May 25 21:11:35 2008 +0200
＠＠ -38,6 +38,14 ＠＠
"Return a new syntax table.
It inherits all characters from the standard syntax table."
(make-char-table 'syntax))
+
+(defun syntax-after (pos)
+ "Return the raw syntax of the char after POS.
+If POS is outside the buffer's accessible portion, return nil."
+ (unless (or (< pos (point-min)) (>= pos (point-max)))
+ (let ((st (if lookup-syntax-properties
+ (get-char-property pos 'syntax-table))))
+ (char-syntax (char-after pos) (or st (syntax-table))))))
(defun simple-set-syntax-entry (char spec table)
(put-char-table char spec table))
diff -r 23ef20edf6ba892a78e7e257a28f4879e31f4095 -r a78d697ccd2c832f5770b564e944a88b4f1f2549 lisp/unicode.el
--- a/lisp/unicode.el Wed May 21 21:09:20 2008 +0200
+++ b/lisp/unicode.el Sun May 25 21:11:35 2008 +0200
＠＠ -506,7 +506,7 ＠＠ The second argument must be 'ucs, the th
;; point). Make them available to user code.
(defvar unicode-error-default-translation-table
(loop
- with char-table = (make-char-table 'char)
+ with char-table = (make-char-table 'generic)
for i from ?\x00 to ?\xFF
initially (unless (featurep 'mule) (return))
do
diff -r 23ef20edf6ba892a78e7e257a28f4879e31f4095 -r a78d697ccd2c832f5770b564e944a88b4f1f2549 lisp/descr-text.el
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/lisp/descr-text.el Sun May 25 21:11:35 2008 +0200
＠＠ -0,0 +1,1284 ＠＠
+;;; descr-text.el --- describe text mode
+
+;; Copyright (C) 1994, 1995, 1996, 2001, 2002, 2003, 2004,
+;; 2005, 2006, 2007 Free Software Foundation, Inc.
+
+;; Author: Boris Goldowsky <boris(a)gnu.org>
+;; Maintainer: FSF
+;; Keywords: faces, i18n, Unicode, multilingual
+
+;; This file is part of XEmacs.
+
+;; XEmacs 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.
+
+;; XEmacs 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 XEmacs; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+
+;;; Commentary:
+
+;;; Describe-Text Mode.
+
+;;; Code:
+
+(eval-when-compile (require 'wid-edit))
+
+;;; Describe-Text Utilities.
+
+(defun describe-text-widget (widget)
+ "Insert text to describe WIDGET in the current buffer."
+ ;; XEmacs change; use the widget function.
+ (widget-create 'push-button
+:notify `(lambda (&rest ignore)
+ (widget-browse ',widget))
+:help-echo
+ "mouse-2, RET: browse this widget"
+ (symbol-name (if (symbolp widget)
+ widget
+ (car widget))))
+ (widget-insert " ")
+ (widget-create 'info-link
+:tag "Widget help"
+:help-echo
+ "Read widget documentation"
+ "(widget)Top"))
+
+(defun describe-text-sexp (sexp)
+ "Insert a short description of SEXP in the current buffer."
+ ;; XEmacs change; use the widget functions.
+ (let ((pp (condition-case signal
+ (pp-to-string sexp)
+ (error (prin1-to-string signal)))))
+ (when (string-match "\n\\'" pp)
+ (setq pp (substring pp 0 (1- (length pp)))))
+ (if (cond ((string-match "\n" pp)
+ nil)
+ ((> (length pp) (- (window-width) (current-column)))
+ nil)
+ (t t))
+ (widget-insert pp)
+ (widget-create 'push-button
+:notify `(lambda (&rest ignore)
+ (with-output-to-temp-buffer
+ "*Pp Eval Output*"
+ (princ ',pp)))
+:help-echo
+ "mouse-2, RET: pretty print value in another buffer"
+ "[Show]"))))
+
+(defun describe-property-list (properties)
+ "Insert a description of PROPERTIES in the current buffer.
+PROPERTIES should be a list of overlay or text properties.
+The `category', `face' and `font-lock-face' properties are made
+into help buttons that call `describe-text-category' or
+`describe-face' when pushed."
+ ;; Sort the properties by the size of their value.
+ (dolist (elt (sort (let (ret)
+ (while properties
+ (push (list (pop properties) (pop properties)) ret))
+ ret)
+ (lambda (a b) (string< (prin1-to-string (nth 0 a) t)
+ (prin1-to-string (nth 0 b) t)))))
+ (let ((key (nth 0 elt))
+ (value (nth 1 elt)))
+ ;; XEmacs change; use #'widget-insert, #'widget-create
+ (widget-insert (propertize (format " %-20s " key)
+ 'face 'hyper-apropos-heading))
+ (cond ((eq key 'category)
+ (widget-create
+ 'push-button
+ :notify `(lambda (&rest ignore)
+ (describe-text-category ',value))
+ :help-echo "mouse-2, RET: describe this category"
+ (symbol-name value)))
+ ((memq key '(face font-lock-face mouse-face))
+ (widget-create
+ 'push-button
+:notify (lexical-let
+ ((value-name (symbol-name value)))
+ (lambda (&rest ignore)
+ (hyper-describe-face (intern value-name))))
+ :help-echo "mouse-2, RET: describe this face"
+ (format "%S" value)))
+ ((widgetp value)
+ (describe-text-widget value))
+ (t
+ (describe-text-sexp value))))
+ (insert "\n")))
+
+;;; Describe-Text Commands.
+
+(defun describe-text-category (category)
+ "Describe a text property category."
+ (interactive "SCategory: ")
+ ; (help-setup-xref (list #'describe-text-category category) (interactive-p))
+ (save-excursion
+ (with-output-to-temp-buffer "*Help*"
+ (set-buffer standard-output)
+ (insert "Category " (format "%S" category) ":\n\n")
+ (describe-property-list (symbol-plist category))
+ (goto-char (point-min)))))
+
+;;;###autoload
+(defun describe-text-properties (pos &optional output-buffer)
+ "Describe widgets, buttons, overlays and text properties at POS.
+Interactively, describe them for the character after point.
+If optional second argument OUTPUT-BUFFER is non-nil,
+insert the output into that buffer, and don't initialize or clear it
+otherwise."
+ (interactive "d")
+ (if (>= pos (point-max))
+ (error "No character follows specified position"))
+ (if output-buffer
+ (describe-text-properties-1 pos output-buffer)
+ (if (not (or (text-properties-at pos) ; (overlays-at pos)))
+ ;; XEmacs change.
+ (extents-at pos)))
+ (message "This is plain text.")
+ (let ((buffer (current-buffer))
+ (target-buffer "*Help*"))
+ (when (eq buffer (get-buffer target-buffer))
+ (setq target-buffer "*Help*<2>"))
+ (save-excursion
+ (with-output-to-temp-buffer target-buffer
+ (set-buffer standard-output)
+ (setq output-buffer (current-buffer))
+ (insert "Text content at position " (format "%d" pos) ":\n\n")
+ (with-current-buffer buffer
+ (describe-text-properties-1 pos output-buffer))
+ (goto-char (point-min))))))))
+
+(defun describe-text-properties-1 (pos output-buffer)
+ (let* ((properties (text-properties-at pos))
+ ;; XEmacs change; extents, not overlays.
+ (extents (extents-at pos))
+ (wid-field (get-char-property pos 'field))
+ (wid-button (get-char-property pos 'button))
+ (wid-doc (get-char-property pos 'widget-doc))
+ ;; If button.el is not loaded, we have no buttons in the text.
+ ;; XEmacs change; use the #'and-fboundp, #'declare-fboundp macros.
+ (button (and-fboundp 'button-at (button-at pos)))
+ (button-type (and button
+ (declare-fboundp (button-type button))))
+ (button-label (and button
+ (declare-fboundp (button-label button))))
+ (widget (or wid-field wid-button wid-doc)))
+ (with-current-buffer output-buffer
+ ;; Widgets
+ (when (widgetp widget)
+ (newline)
+ (insert (cond (wid-field "This is an editable text area")
+ (wid-button "This is an active area")
+ (wid-doc "This is documentation text")))
+ (insert " of a ")
+ (describe-text-widget widget)
+ (insert ".\n\n"))
+ ;; Buttons
+ (when (and button (not (widgetp wid-button)))
+ (newline)
+ (insert "Here is a `" (format "%S" button-type)
+ "' button labeled `" button-label "'.\n\n"))
+ ;; Overlays
+ (when extents
+ (newline)
+ (if (eq (length extents) 1)
+ (insert "There is an extent here:\n")
+ (insert "There are " (format "%d" (length extents))
+ " overlays here:\n"))
+ (dolist (extent extents)
+ (insert " From " (format "%d" (extent-start-position extent))
+ " to " (format "%d" (extent-end-position extent)) "\n")
+ (describe-property-list (extent-properties extent)))
+ (insert "\n"))
+ ;; Text properties
+ (when properties
+ (newline)
+ (insert "There are text properties here:\n")
+ (describe-property-list properties)))))
+
+(defcustom describe-char-unicodedata-file
+ ;; XEmacs change; initialise this by default, using Perl.
+ (let ((have-perl
+ (member-if
+ #'(lambda (path)
+ (file-exists-p (format "%s%cperl" path directory-sep-char)))
+ exec-path))
+ installprivlib res)
+ (when have-perl
+ (setq installprivlib
+ (with-string-as-buffer-contents ""
+ (shell-command "perl -V:installprivlib" t)
+ ;; 1+ because buffer offsets start at one.
+ (delete-region 1 (1+ (length "installprivlib='")))
+ ;; Delete the final newline, semicolon and quotation mark.
+ (delete-region (- (point-max) 3) (point-max))))
+ (cond
+ ((file-exists-p
+ (setq res
+ (format "%s%cunicore%cUnicodeData.txt"
+ installprivlib directory-sep-char directory-sep-char))))
+ ((file-exists-p
+ (setq res
+ (format "%s%cunicode%cUnicodeData.txt"
+ installprivlib directory-sep-char directory-sep-char)))))
+ res))
+ "Location of Unicode data file.
+This is the UnicodeData.txt file from the Unicode Consortium, used for
+diagnostics. If it is non-nil `describe-char' will print data
+looked up from it. This facility is mostly of use to people doing
+multilingual development.
+
+This is a fairly large file, typically installed with Perl.
+At the time of writing it is at the URL
+`http://www.unicode.org/Public/UNIDATA/UnicodeData.txt'.
+
+It is possible to build a DBM or Berkeley index cache for this file, so that
+it is not necessary to parse the whole file at run time. See
+`unidata-initialize-unicodedata-database'.
+
+See also `describe-char-unihan-file' for the complementary file describing
+East Asian Han characters and their associated information."
+
+:group 'mule
+:type '(choice (const :tag "None" nil)
+ file))
+
+;; XEmacs additions, from here until `describe-char-unicode-data'
+(defcustom describe-char-use-cache t
+ "Whether `describe-char' should use a DBM or Berkeley DB cache.
+This speeds up navigation of `describe-char-unicodedata-file', and makes
+navigation of `describe-char-unihan-file' reasonable."
+:group 'mule
+:type '(choice (const :tag "None" nil)
+ file))
+
+(defcustom describe-char-unihan-file nil
+ "Location of Unihan file.
+This the Unihan.txt file from the Unicode Consortium, used for diagnostics.
+If it is non-nil `describe-char' can print data looked up from it. This
+facility is of use to people doing multilingual development, to those
+learning Chinese or Japanese, and to a lesser extent to those learning
+Korean or Vietnamese.
+
+This is large file, typically not installed with the operating system. At
+the time of writing it is at the URL
+`http://www.unicode.org/Public/UNIDATA/UniHan.txt'.
+
+In contrast with `describe-char-unicodedata-file', `describe-char' will not
+load this entire file and parse it if it is available. It requires a
+pre-initialized cache; see `unidata-initialize-unihan-database'. "
+:group 'mule
+:type '(choice (const :tag "None" nil)
+ file))
+
+;; XEmacs addition
+(defvar unidata-database-format
+ (or (and (featurep 'dbm) 'dbm)
+ (and (featurep 'berkeley-db) 'berkeley-db))
+ "The DB format to use for the `describe-char' cache, or nil if no cache.")
+
+(defvar describe-char-unihan-field-descriptions
+ #s(hash-table test equal data
+ ("kAccountingNumeric"
+ "Value as an an accounting numeral"
+ "kBigFive"
+ "Big Five mapping (excluding ETEN, etc. extensions)"
+ "kCCCII"
+ "Hex CCCII code, for libraries in the Republic of China"
+ "kCNS1986"
+ "Hex CNS 11643-1986 mapping, for the Republic of China"
+ "kCNS1992"
+ "Hex CNS 11643-1986 mapping, for the Republic of China"
+ "kCangjie"
+ "Cangjie input code for the character"
+ "kCantonese"
+ "Cantonese pronunciation, using jyutping"
+ "kCheungBauer"
+ "Radical-stroke index, cangjie input code, \
+and Cantonese readings"
+ "kCheungBauerIndex"
+ "Index of information about this character \
+in Cheung & Bauer, 2002"
+ "kCihaiT"
+ "Lookup information for this character in the \
+Cihai dictionary ISBN 962-231-005-2."
+ "kCompatibilityVariant"
+ "Compatibility decomposition for this character"
+ "kCowles"
+ "Lookup information for this character in the \
+Cowles dictionary ISBN 962-231-005-2."
+ "kDaeJaweon"
+ "Lookup information for this character in the \
+Dae Jaweon (Korean) dictionary, 1988"
+ "kDefinition"
+ "Definition for this character in modern written Chinese"
+ "kEACC"
+ "The EACC (= CCCII, as used by the \
+US library of congress) code for this character"
+ "kFenn"
+ "Frequency information for this character from \
+Fenn's Chinese-English dictionary, 1979"
+ "kFennIndex"
+ "Lookup information for this character in \
+Fenn's Chinese-English dictionary, 1979"
+ "kFourCornerCode"
+ "Four-corner lookup code for this character"
+ "kFrequency"
+ "Frequency information from traditional \
+Chinese USENET postings"
+ "kGB0" "GB 2312-80 mapping, ku/ten"
+ "kGB1" "GB 12345-90 mapping, ku/ten"
+ "kGB3" "GB 7589-87 mapping, ku/ten"
+ "kGB5" "GB 7590-87 mapping, ku/ten"
+ "kGB7" "GB 8565-89 mapping, ku/ten"
+ ;; Identical to the previous information?!
+ "kGB8" "GB 8565-89 mapping, ku/ten"
+ "kGSR"
+ "Lookup information for this character in \
+Karlgern's Grammata Serica Recensa"
+ "kGradeLevel"
+ "The first grade in the HK school system \
+where knowledge of this character is expected"
+ "kHDZRadBreak" "Whether Hanyu Da Zidian has a radical break \
+beginning with this character"
+ "kHKGlyph" "Lookup information for this character in the HK \
+glyph reference, ISBN 962-949-040-4"
+ "kHKSCS" "Mapping to the HK Supplementary Character Set for \
+Big Five."
+ "kHanYu" "Character lookup information for Hanyu Da Zidian, \
+`Great Chinese Character Dictionary'"
+ "kHangul" "Korean pronunciation"
+ "kHanyuPinlu" "Pronunciation and frequency info, from Xiandai\
+ Hanyu Pinlu Cidian"
+ "kIBMJapan" "IBM Japanese mapping"
+ "kIICore" "Is this character in the core East Asian \
+ideograph set from the IRG?"
+ "kIRGDaeJaweon" "Lookup information for this character \
+in the Dae Jaweon (Korean) dictionary"
+ "kIRGDaiKanwaZiten" "Lookup information for this character \
+in the Morohashi (Japanese) dictionary"
+ "kIRGHanyuDaZidian" "Lookup information for this character \
+in the Hanyu Da Zidian (Chinese) dictionary"
+ "kIRGKangXi" "Lookup information for this character \
+in the KangXi dictionary"
+ "kIRG_GSource" "PRC character source information"
+ "kIRG_HSource" "Hong Kong character source information"
+ "kIRG_JSource" "Japanese character source information"
+ "kIRG_KPSource" "Korean character source information"
+ "kIRG_KSource" "Republic of Korean character source\
+ information"
+ "kIRG_TSource" "Republic of China character source \
+information"
+ "kIRG_USource" "Unicode (standards body) source information"
+ "kIRG_VSource" "Vietnamese character source information"
+ "kJIS0213" "JIS X 0213-2000 mapping in min,ku,ten form"
+ "kJapaneseKun" "Native Japanese pronunciation"
+ "kJapaneseOn" "Sino-Japanese pronunciation"
+ "kJis0" "JIS X 0208-1990 mapping in ku/ten form"
+ "kJis1" "JIS X 0212-1990 mapping in ku/ten form"
+ "kKPS0" "KPS 9566-97 mapping in hexadecimal"
+ "kKPS1" "KPS 10721-2000 mapping in hexadecimal"
+ "kKSC0" "KS X 1001:1992 (KS C 5601-1989) mapping \
+in ku/ten form"
+ "kKSC1" "KS X 1002:1991 (KS C 5657-1991) mapping \
+in ku/ten form"
+ "kKangXi" "Lookup information for this character \
+in the KangXi (Chinese) dictionary"
+ "kKarlgren" "Lookup information for this character \
+in Karlgren's dictionary, 1974"
+ "kKorean" "Pronunciation in Korean"
+ "kLau" "Lookup information for this character \
+in Lau's Cantonese-English dictionary"
+ "kMainlandTelegraph" "PRC telegraph code"
+ "kMandarin" "Mandarin pronunciation in Pinyin"
+ "kMatthews" "Lookup information for Robert Mathews' \
+Chinese-English dictionary"
+ "kMeyerWempe" "Lookup information for Bernard Meyer and \
+Theodore Wempe's dictionary"
+ ;; Identical to kIRGDaiKanwaZiten?!?
+ "kMorohashi" "Lookup information for this character \
+in the Morohashi (Japanese) dictionary"
+ "kNelson" "Lookup information for this character in \
+Nelson's Japanese-English dictionary"
+ "kOtherNumeric" "Esoteric numeric value"
+ "kPhonetic" "Phonetic index data"
+ "kPrimaryNumeric" "Standard numeric value"
+ "kPseudoGB1" "Fake GB 12345-90, for the purposes of \
+Unicode inclusion"
+ "kRSAdobe_Japan1_6" "Adobe-Japan1-6 information for \
+the character"
+ "kRSJapanese" "Radical/stroke count for Japanese"
+ "kRSKanWa" "Morohashi radical/stroke count"
+ "kRSKangXi" "KangXi radical/stroke count"
+ "kRSKorean" "Korean radical/stroke count"
+ "kRSUnicode" "Unicode radical/stroke count"
+ "kSBGY" "Lookup information for this character in the Song \
+Ben Guang Yun Chinese dictionary"
+ "kSemanticVariant" "Semantic variant character"
+ "kSimplifiedVariant" "Simplified variant character"
+ "kSpecializedSemanticVariant" "Specialized semantic variant"
+ "kTaiwanTelegraph" "Taiwanese telegraph code"
+ "kTang" "Tang dynasty pronunciation"
+ "kTotalStrokes" "Total number of strokes"
+ "kTraditionalVariant" "Traditional variant character"
+ "kVietnamese" "Vietnamese pronunciation"
+ "kXerox" "Xerox code"
+ "kZVariant" "Z-variant code(s)"))
+ "A map from symbolic Unihan field names to English-language descriptions.")
+
+(defun unidata-generate-database-file-name (unidata-file-name size
+ database-format)
+ "Return a filename suitable for storing the cache for UNIDATA-FILE-NAME."
+ (expand-file-name
+ (format "~%c.xemacs%c%s-%s" directory-sep-char directory-sep-char
+ (md5 (format "%s-%d" unidata-file-name size))
+ database-format)))
+
+(defun unidata-initialize-unicodedata-database (unidata-file-name)
+ "Init the berkeley or gdbm lookup table for UNIDATA-FILE-NAME.
+
+The table is a (non-SQL) database with information on the file offset of
+each Unicode code point described in UNIDATA-FILE-NAME. In the normal
+course of events UNIDATA-FILE-NAME is the value of
+`unidata-default-file-name', which see. "
+ (check-argument-type #'file-readable-p unidata-file-name)
+ (unless unidata-database-format
+ (error 'unimplemented "No (non-SQL) DB support available"))
+ (let* ((database-format unidata-database-format)
+ (size (eighth (file-attributes unidata-file-name)))
+ (database-file-name
+ (unidata-generate-database-file-name unidata-file-name
+ size database-format))
+ (database-handle (open-database database-file-name database-format
+ nil "rw+" #o644 'no-conversion-unix))
+ (coding-system-for-read 'no-conversion-unix)
+ (buffer-size 32768)
+ (offset-start 0)
+ (offset-end buffer-size)
+ (range-information (make-range-table 'start-closed-end-closed))
+ (range-staging (make-hash-table :test 'equal))
+ (message "Initializing UnicodeData database cache: ")
+ (loop-count 1)
+ range-startinfo)
+ (with-temp-buffer
+ (progress-feedback-with-label 'describe-char-unicodedata-file
+ "%s" 0 message)
+ (while (progn
+ (delete-region (point-min) (point-max))
+ (insert-file-contents unidata-file-name nil
+ offset-start offset-end)
+ ;; If we've reached the end of the data, pass nil back to
+ ;; the while loop test.
+ (not (= (point-min) (point-max))))
+
+ (when (= buffer-size (- (point-max) (point-min)))
+ ;; If we're in the body of the file, and there's a trailing
+ ;; incomplete end-line, delete it, and adjust offset-end
+ ;; appropriately.
+ (goto-char (point-max))
+ (search-backward "\n")
+ (forward-char)
+ (delete-region (point) (point-max))
+ (setq offset-end (+ offset-start (- (point) (point-min)))))
+
+ (progress-feedback-with-label 'describe-char-unicodedata-file
+ "%s" (truncate
+ (* (/ offset-start size) 100))
+ (concat message
+ (make-string
+ (mod loop-count 39) ?.)))
+ (incf loop-count)
+ (goto-char (point-min))
+ (while (re-search-forward
+ #r"^\([0-9A-F]\{4,6\}\);\([^;]*\);.*$" nil t)
+ (cond
+ ((and (> (- (match-end 2) (match-beginning 2)) 7)
+ (equal (substring (match-string 2) -7)
+ " First>"))
+ ;; Start of a range. Save the start info in range-staging.
+ (puthash (substring (match-string 2) 0 -7)
+ (list (string-to-int (match-string 1) 16)
+ (+ offset-start (1- (match-beginning 0))))
+ range-staging))
+ ((and (> (- (match-end 2) (match-beginning 2)) 7)
+ (equal (substring (match-string 2) -6)
+ " Last>"))
+ ;; End of a range. Combine with the start info, save it to the
+ ;; range-information range table.
+ (setq range-startinfo
+ (gethash (substring (match-string 2) 0 -6) range-staging))
+ (assert range-startinfo nil
+ "Unexpected order for range information.")
+ (put-range-table
+ (first range-startinfo)
+ (string-to-int (match-string 1) 16)
+ (list (second range-startinfo)
+ (+ offset-start (1- (match-end 0))))
+ range-information)
+ (remhash (substring (match-string 2) 0 -6) range-staging))
+ (t
+ ;; Normal character. Save the associated information in the
+ ;; database directly.
+ (put-database (match-string 1)
+ (format "(%d %d)"
+ (+ offset-start (1- (match-beginning 0)))
+ (+ offset-start (1- (match-end 0))))
+ database-handle))))
+ (goto-char (point-min))
+ (setq offset-start offset-end
+ offset-end (+ buffer-size offset-end))))
+ ;; Save the range information as such in the database.
+ (put-database "range-information"
+ (let ((print-readably t))
+ (prin1-to-string range-information))
+ database-handle)
+ (close-database database-handle)
+ (progress-feedback-with-label 'describe-char-unicodedata-file
+ "%s" 100 message)
+ database-file-name))
+
+(defun unidata-initialize-unihan-database (unihan-file-name)
+ "Init the berkeley or gdbm lookup table for UNIHAN-FILE-NAME.
+
+The table is a (non-SQL) database with information on the file offset of
+each Unicode code point described in Unicode.org's Han character repository.
+Unihan.txt (see `describe-char-unihan-file', the usual argument to this
+function) is very large, and manipulating it directly can be tedious and
+slow, so creating this cache makes it reasonable to display Unihan info in
+the output of \\[universal-argument] \\[what-cursor-position] . "
+ (check-argument-type #'file-readable-p unihan-file-name)
+ (unless unidata-database-format
+ (error 'unimplemented "No (non-SQL) DB support available"))
+ (let* ((database-format unidata-database-format)
+ (size (eighth (file-attributes unihan-file-name)))
+ (database-file-name
+ (unidata-generate-database-file-name unihan-file-name
+ size database-format))
+ (database-handle (open-database database-file-name database-format
+ nil "rw+" #o644 'no-conversion-unix))
+ (coding-system-for-read 'no-conversion-unix)
+ (buffer-size 65536)
+ (offset-start 0)
+ (offset-end buffer-size)
+ (message "Initializing Unihan database cache: ")
+ (loop-count 1)
+ trailing-unicode leading-unicode character-start character-end)
+ (with-temp-buffer
+ (progress-feedback-with-label 'describe-char-unihan-file
+ "%s" 0 message)
+ (while (progn
+ (delete-region (point-min) (point-max))
+ (insert-file-contents unihan-file-name nil
+ offset-start offset-end)
+ ;; If we've reached the end of the data, return nil to the
+ ;; while.
+ (not (= (point-min) (point-max))))
+
+ (incf loop-count)
+ (progress-feedback-with-label 'describe-char-unihan-file
+ "%s" (truncate
+ (* (/ offset-start size) 100))
+ (concat message
+ (make-string
+ (mod loop-count 44) ?.)))
+ (block 'dealing-with-chars
+ (when (= buffer-size (- (point-max) (point-min)))
+ ;; If we're in the body of the file, we need to delete the
+ ;; character info for the last character, and set offset-end
+ ;; appropriately. Otherwise, we may not be able to pick where
+ ;; the actual description of a character ends and
+ ;; begins.
+ ;;
+ ;; This breaks if any single Unihan character description is
+ ;; greater than the buffer size in length.
+ (goto-char (point-max))
+ (beginning-of-line)
+
+ (when (< (- (point-max) (point)) (eval-when-compile
+ (length "U+ABCDEF\t")))
+ ;; If the character ID of the last line may have been cut off,
+ ;; we need to delete all of that line here.
+ (delete-region (point) (point-max))
+ (forward-line -1))
+
+ (when (looking-at "^\\(U\\+[0-9A-F]\\{4,6\\}\\)\t")
+ (setq trailing-unicode (match-string 1)
+ trailing-unicode
+ (format "^%s\t" (regexp-quote trailing-unicode)))
+
+ (end-of-line)
+
+ ;; Go back until we hit a line that doesn't start with this
+ ;; character info.
+ (while (re-search-backward trailing-unicode nil t))
+
+ ;; The re-search-backward failed, so point is still at the end
+ ;; of the last match. Move to its beginning.
+ (beginning-of-line)
+ (delete-region (point) (point-max))
+ (setq offset-end (+ offset-start (- (point) (point-min))))))
+ (goto-char (point-min))
+ (while t
+ (when (= (point) (point-max))
+ ;; We're at the end of this part of the file.
+ (return-from 'dealing-with-chars))
+
+ (unless (re-search-forward "^\\(U\\+[0-9A-F]\\{4,6\\}\\)\t"
+ nil t)
+ ;; We're probably in the comments at the start of the file. No
+ ;; need to look for character info.
+ (return-from 'dealing-with-chars))
+
+ ;; Store where the character started.
+ (beginning-of-line)
+ (setq character-start (point))
+
+ (setq leading-unicode
+ (format "^%s\t" (regexp-quote (match-string 1))))
+
+ ;; Loop until we get past this entry.
+ (while (re-search-forward leading-unicode nil t))
+
+ ;; Now, store the information.
+ (setq leading-unicode
+ (string-to-number (substring leading-unicode 3) 16)
+ leading-unicode (format "%04X" leading-unicode)
+ character-end (prog2 (end-of-line) (point)))
+ (put-database leading-unicode
+ (format "(%d %d)"
+ (+ offset-start (1- character-start))
+ (+ offset-start (1- character-end)))
+ database-handle)
+ (forward-line)))
+ (setq offset-start offset-end
+ offset-end (+ buffer-size offset-end))))
+ (close-database database-handle)
+ (progress-feedback-with-label 'describe-char-unihan-file
+ "%s" 100
+ message)
+ database-file-name))
+;; End XEmacs additions.
+
+(defun describe-char-unicode-data (char)
+ "Return a list of Unicode data for unicode CHAR.
+Each element is a list of a property description and the property value.
+The list is null if CHAR isn't found in `describe-char-unicodedata-file'."
+ (when describe-char-unicodedata-file
+ (unless (file-exists-p describe-char-unicodedata-file)
+ (error 'file-error
+ "`unicodedata-file' %s not found" describe-char-unicodedata-file))
+ ;; XEmacs change; accept a character argument, use the cache if
+ ;; appropriate.
+ (when (characterp char)
+ (setq char (encode-char char 'ucs)))
+ (with-temp-buffer
+ (if describe-char-use-cache
+ ;; Use the database info.
+ (let ((database-handle (open-database
+ (unidata-generate-database-file-name
+ describe-char-unicodedata-file
+ (eighth (file-attributes
+ describe-char-unicodedata-file))
+ unidata-database-format)
+ unidata-database-format
+ nil "r"
+ #o644 'no-conversion-unix))
+ (coding-system-for-read 'no-conversion-unix)
+ key lookup)
+ (unless database-handle
+ (error 'io-error "Could not open %s as a %s database"
+ (unidata-generate-database-file-name
+ describe-char-unicodedata-file
+ (eighth (file-attributes
+ describe-char-unicodedata-file))
+ unidata-database-format)
+ unidata-database-format))
+ (setq key (format "%04X" char)
+ lookup (get-database key database-handle))
+ (if lookup
+ ;; Okay, we have information on that character in particular.
+ (progn (setq lookup (read lookup))
+ (insert-file-contents describe-char-unicodedata-file nil
+ (first lookup) (second lookup)))
+ ;; No information on that character in particular. Do we have
+ ;; range information? If so, load and check for our desired
+ ;; character.
+ (setq lookup (get-database "range-information" database-handle)
+ lookup (if lookup (read lookup))
+ lookup (if lookup (get-range-table char lookup)))
+ (when lookup
+ (insert-file-contents describe-char-unicodedata-file nil
+ (first lookup) (second lookup))))
+ (close-database database-handle))
+
+ ;; Otherwise, insert the whole file (the FSF approach).
+ (set-buffer (get-buffer-create " *Unicode Data*"))
+ (when (zerop (buffer-size))
+ ;; Don't use -literally in case of DOS line endings.
+ (insert-file-contents describe-char-unicodedata-file)))
+
+ (goto-char (point-min))
+ (let ((hex (format "%04X" char))
+ found first last unihan-match unihan-info
+ (unihan-database-handle
+ (and describe-char-unihan-file
+ (open-database (unidata-generate-database-file-name
+ describe-char-unihan-file
+ (eighth (file-attributes
+ describe-char-unihan-file))
+ unidata-database-format)
+ unidata-database-format
+ nil "r" #o644 'no-conversion-unix)))
+ (coding-system-for-read 'no-conversion-unix))
+ (if (re-search-forward (concat "^" hex) nil t)
+ (setq found t)
+ ;; It's not listed explicitly. Look for ranges, e.g. CJK
+ ;; ideographs, and check whether it's in one of them.
+ (while (and (re-search-forward "^\\([^;]+\\);[^;]+First>;" nil t)
+ (>= char (setq first
+ (string-to-number (match-string 1) 16)))
+ (progn
+ (forward-line 1)
+ (looking-at "^\\([^;]+\\);[^;]+Last>;")
+ (> char
+ (setq last
+ (string-to-number (match-string 1) 16))))))
+ (if (and first (>= char first)
+ last (<= char last))
+ (setq found t)))
+ (if found
+ (let ((fields (mapcar (lambda (elt)
+ (if (> (length elt) 0)
+ elt))
+ (cdr (split-string
+ (buffer-substring
+ (line-beginning-position)
+ (line-end-position))
+ ";")))))
+ ;; The length depends on whether the last field was empty.
+ (unless (or (= 13 (length fields))
+ (= 14 (length fields)))
+ (error 'invalid-argument
+ "Invalid contents in %s" describe-char-unicodedata-file))
+ ;; The field names and values lists are slightly
+ ;; modified from Mule-UCS unidata.el.
+ (apply #'list
+ (list "Name" (let ((name (nth 0 fields)))
+ ;; Check for <..., First>, <..., Last>
+ (if (string-match "\\`\\(<[^,]+\\)," name)
+ (concat (match-string 1 name) ">")
+ name)))
+ (list "Category"
+ (cdr (assoc
+ (nth 1 fields)
+ '(("Lu" . "uppercase letter")
+ ("Ll" . "lowercase letter")
+ ("Lt" . "titlecase letter")
+ ("Mn" . "non-spacing mark")
+ ("Mc" . "spacing-combining mark")
+ ("Me" . "enclosing mark")
+ ("Nd" . "decimal digit")
+ ("Nl" . "letter number")
+ ("No" . "other number")
+ ("Zs" . "space separator")
+ ("Zl" . "line separator")
+ ("Zp" . "paragraph separator")
+ ("Cc" . "other control")
+ ("Cf" . "other format")
+ ("Cs" . "surrogate")
+ ("Co" . "private use")
+ ("Cn" . "not assigned")
+ ("Lm" . "modifier letter")
+ ("Lo" . "other letter")
+ ("Pc" . "connector punctuation")
+ ("Pd" . "dash punctuation")
+ ("Ps" . "open punctuation")
+ ("Pe" . "close punctuation")
+ ("Pi" . "initial-quotation punctuation")
+ ("Pf" . "final-quotation punctuation")
+ ("Po" . "other punctuation")
+ ("Sm" . "math symbol")
+ ("Sc" . "currency symbol")
+ ("Sk" . "modifier symbol")
+ ("So" . "other symbol")))))
+ (list "Combining class"
+ (cdr (assoc
+ (string-to-number (nth 2 fields))
+ '((0 . "Spacing")
+ (1 . "Overlays and interior")
+ (7 . "Nuktas")
+ (8 . "Hiragana/Katakana voicing marks")
+ (9 . "Viramas")
+ (10 . "Start of fixed position classes")
+ (199 . "End of fixed position classes")
+ (200 . "Below left attached")
+ (202 . "Below attached")
+ (204 . "Below right attached")
+ (208 . "Left attached (reordrant around \
+single base character)")
+ (210 . "Right attached")
+ (212 . "Above left attached")
+ (214 . "Above attached")
+ (216 . "Above right attached")
+ (218 . "Below left")
+ (220 . "Below")
+ (222 . "Below right")
+ (224 . "Left (reordrant around single base \
+character)")
+ (226 . "Right")
+ (228 . "Above left")
+ (230 . "Above")
+ (232 . "Above right")
+ (233 . "Double below")
+ (234 . "Double above")
+ (240 . "Below (iota subscript)")))))
+ (list "Bidi category"
+ (cdr (assoc
+ (nth 3 fields)
+ '(("L" . "Left-to-Right")
+ ("LRE" . "Left-to-Right Embedding")
+ ("LRO" . "Left-to-Right Override")
+ ("R" . "Right-to-Left")
+ ("AL" . "Right-to-Left Arabic")
+ ("RLE" . "Right-to-Left Embedding")
+ ("RLO" . "Right-to-Left Override")
+ ("PDF" . "Pop Directional Format")
+ ("EN" . "European Number")
+ ("ES" . "European Number Separator")
+ ("ET" . "European Number Terminator")
+ ("AN" . "Arabic Number")
+ ("CS" . "Common Number Separator")
+ ("NSM" . "Non-Spacing Mark")
+ ("BN" . "Boundary Neutral")
+ ("B" . "Paragraph Separator")
+ ("S" . "Segment Separator")
+ ("WS" . "Whitespace")
+ ("ON" . "Other Neutrals")))))
+ (list
+ "Decomposition"
+ (if (nth 4 fields)
+ (let* ((parts (split-string (nth 4 fields)))
+ (info (car parts)))
+ (if (string-match "\\`<\\(.+\\)>\\'" info)
+ (setq info (match-string 1 info))
+ (setq info nil))
+ (if info (setq parts (cdr parts)))
+ ;; Maybe printing ? for unrepresentable unicodes
+ ;; here and below should be changed?
+ (setq parts (mapconcat
+ (lambda (arg)
+ (string (or (decode-char
+ 'ucs
+ (string-to-number arg 16))
+ ??)))
+ parts " "))
+ (concat info parts))))
+ (list "Decimal digit value"
+ (nth 5 fields))
+ (list "Digit value"
+ (nth 6 fields))
+ (list "Numeric value"
+ (nth 7 fields))
+ (list "Mirrored"
+ (if (equal "Y" (nth 8 fields))
+ "yes"))
+ (list "Old name" (nth 9 fields))
+ (list "ISO 10646 comment" (nth 10 fields))
+ (list "Uppercase" (and (nth 11 fields)
+ (string (or (decode-char
+ 'ucs
+ (string-to-number
+ (nth 11 fields) 16))
+ ??))))
+ (list "Lowercase" (and (nth 12 fields)
+ (string (or (decode-char
+ 'ucs
+ (string-to-number
+ (nth 12 fields) 16))
+ ??))))
+ (list "Titlecase" (and (nth 13 fields)
+ (string (or (decode-char
+ 'ucs
+ (string-to-number
+ (nth 13 fields) 16))
+ ??))))
+
+ ;; XEmacs addition.
+ ;; If we're aware the character is a Han character, provide
+ ;; the Unihan information, or tell the user that it's not
+ ;; available.
+ (if (and (> (length (nth 0 fields)) 13)
+ (equal "<CJK Ideograph"
+ (substring (nth 0 fields) 0 14)))
+ (if (and unihan-database-handle
+ (setq unihan-match
+ (get-database (format "%04X" char)
+ unihan-database-handle)
+ unihan-match
+ (and unihan-match (read unihan-match))))
+ (with-temp-buffer
+ (insert-file-contents describe-char-unihan-file
+ nil (first unihan-match)
+ (second unihan-match))
+ (goto-char (point-min))
+ (while (re-search-forward
+ "^U\\+[0-9A-F]+\t\\(k[^\t]+\\)\t\\(.*\\)$"
+ nil t)
+ (push
+ (list
+ (or (gethash
+ (match-string 1)
+ describe-char-unihan-field-descriptions)
+ (match-string 1))
+ (decode-coding-string (match-string 2) 'utf-8))
+ unihan-info))
+ (close-database unihan-database-handle)
+ unihan-info)
+ ;; It's a Han character, but Unihan.txt is not
+ ;; available. Tell the user.
+ (list
+ '("Unihan"
+ "No Unihan information available; is \
+`describe-char-unihan-file' set, and its cache initialized?")))))))))))
+
+;; Return information about how CHAR is displayed at the buffer
+;; position POS. If the selected frame is on a graphic display,
+;; return a cons (FONTNAME . GLYPH-CODE). Otherwise, return a string
+;; describing the terminal codes for the character.
+(defun describe-char-display (pos char)
+ (let* ((frame (selected-frame))
+ (charset (char-charset char))
+ (ccl (or (and (charset-property charset 'encode-as-utf-8)
+ ccl-encode-to-ucs-2)
+ (charset-property charset 'ccl-program)))
+ (ccl-vector (make-vector 8 0)))
+ (if (display-graphic-p (selected-frame))
+ (list
+ (font-instance-name
+ (face-font-instance (or (get-char-property pos 'face)
+ 'default)
+ (selected-window)
+ charset))
+ (cond
+ ((and ccl (eq 'x (frame-type frame)))
+ (setq char (split-char char))
+ (aset ccl-vector 0 (charset-id charset))
+ (aset ccl-vector 1 (second char))
+ (if (= 2 (charset-dimension charset))
+ (aset ccl-vector 2 (third char)))
+ (ccl-execute ccl ccl-vector)
+ (if (= 2 (charset-dimension charset))
+ (logior (lsh (aref ccl-vector 1) 8)
+ (aref ccl-vector 2))
+ (aref ccl-vector 1)))
+ ;; #### We don't handle the X case where redisplay falls back to an
+ ;; ISO 10646-1 font at runtime.
+ ((eq 'x (frame-type frame))
+ (if (= 2 (charset-dimension charset))
+ (prog2
+ (setq char (split-char char))
+ (logior (lsh (second char) 8)
+ (third char)))
+ (second (split-char char))))
+ ;; Otherwise we assume we're using Unicode.
+ (t
+ (encode-char char 'ucs))))
+ (let* ((coding (console-tty-output-coding-system (device-console)))
+ (encoded (encode-coding-string char coding)))
+ (if encoded
+ (format "%s, coding system %s"
+ (encoded-string-description encoded coding)
+ (coding-system-name coding)))))))
+
+
+;;;###autoload
+(defun describe-char (pos)
+ "Describe the character after POS (interactively, the character after point).
+The information includes character code, charset and code points in it,
+syntax, category, how the character is encoded in a file,
+character composition information (if relevant),
+as well as widgets, buttons, overlays, and text properties."
+ (interactive "d")
+ (if (>= pos (point-max))
+ (error "No character follows specified position"))
+ (let* ((char (char-after pos))
+ (charset (char-charset char))
+ (composition (find-composition pos nil nil t))
+ (component-chars nil)
+ (display-table
+ (specifier-instance current-display-table (selected-window)))
+ (disp-table-entry (and display-table
+ (get-display-table char display-table)))
+ (extents (mapcar #'(lambda (o) (extent-properties o))
+ (extents-at pos)))
+ (char-description (single-key-description char))
+ (text-props-desc
+ (let ((tmp-buf (generate-new-buffer " *text-props*")))
+ (unwind-protect
+ (progn
+ (describe-text-properties pos tmp-buf)
+ (with-current-buffer tmp-buf (buffer-string)))
+ (kill-buffer tmp-buf))))
+ item-list max-width unicode unicode-formatted unicode-error)
+
+
+ (setq unicode-error
+ ;; XEmacs change, check does the character represent a Unicode
+ ;; error sequence.
+ (get-char-table char unicode-error-default-translation-table)
+ unicode (and (not unicode-error) (encode-char char 'ucs))
+ unicode-formatted (if unicode-error
+ (format
+ "Invalid Unicode sequence, ?\x%02x on disk"
+ unicode-error)
+ (if (and unicode (natnump unicode))
+ (format (if (> unicode #xFFFF)
+ "U+%06X" "U+%04X")
+ unicode)
+ ""))
+ item-list
+ `(("character"
+ ,(format "%s (%s, %d, #o%o, #x%x)"
+ (apply 'propertize char-description
+ (text-properties-at pos))
+ unicode-formatted
+ char
+ char
+ char))
+ ("charset"
+ ,(lexical-let
+ ((charset-name (symbol-name charset)))
+ `(progn
+ (widget-create 'push-button
+:notify ,(lambda (&rest ignored-arg)
+ (with-displaying-help-buffer
+ (lambda nil
+ (charset-description
+ (intern charset-name)))
+ charset-name))
+ ,charset-name)
+ (widget-insert (format " (%s)" (charset-description
+ ',charset))))))
+ ("code point"
+ ,(let ((split (split-char char)))
+ `(widget-create 'push-button
+;:notify
+; ,(lambda (&rest ignored-arg)
+; (with-selected-wind
+; insert-gui-button
+; (make-gui-button
+ ,(if (= (charset-dimension charset) 1)
+ (format "#x%02X" (nth 1 split))
+ (format "#x%02X #x%02X" (nth 1 split)
+ (nth 2 split))))))
+ ("syntax"
+ ,(let ((syntax
+ (syntax-string-to-code (string (syntax-after pos)))))
+ (with-temp-buffer
+ (describe-syntax-code syntax (current-buffer))
+ ;; Remove the newline.
+ (delete-backward-char)
+ (buffer-string))))
+ ;; XEmacs; #### add category support.
+; ("category"
+; ,＠(let ((category-set (char-category-set char)))
+; (if (not category-set)
+; '("-- none --")
+; (mapcar #'(lambda (x) (format "%c:%s"
+; x (category-docstring x)))
+; (category-set-mnemonics category-set)))))
+; ,＠(let ((props (get-char-table char char-code-property-table))
+; ps)
+; (when props
+; (while props
+; (push (format "%s:" (pop props)) ps)
+; (push (format "%s;" (pop props)) ps))
+; (list (cons "Properties" (nreverse ps)))))
+ ("to input"
+ ,＠(let ((key-list (and-fboundp #'quail-find-key
+ current-input-method
+ (quail-find-key char))))
+ (if (consp key-list)
+ (list "type"
+ (mapconcat #'(lambda (x) (concat "\"" x "\""))
+ key-list " or ")
+ "with"
+ `(insert-text-button
+ ,current-input-method
+ 'type 'help-input-method
+ 'help-args '(,current-input-method))))))
+; ("buffer code"
+; ,(encoded-string-description
+; (string-as-unibyte (char-to-string char) nil))
+ ("file code"
+ ,＠(let* ((coding buffer-file-coding-system)
+ ;; ### XEmacs; use encode-coding-char once
+ ;; merged.
+ (encoded (encode-coding-string char coding)))
+ (if encoded
+ (list (encoded-string-description encoded coding)
+ (format "(encoded by coding system %S)"
+ (coding-system-name coding)))
+ (list "not encodable by coding system"
+ (coding-system-name coding)))))
+ ("display"
+ ,(cond
+ (disp-table-entry
+ ;; XEmacs change; just use the print syntax of the display
+ ;; table entry. Might be possible to improve this, but
+ ;; nothing occurs to me right now.
+ (format "by display table entry [%S] " disp-table-entry))
+ (composition
+ (let ((from (car composition))
+ (to (nth 1 composition))
+ (next (1+ pos))
+ (components (nth 2 composition))
+ ch)
+ (setcar composition
+ (and (< from pos) (buffer-substring from pos)))
+ (setcar (cdr composition)
+ (and (< next to) (buffer-substring next to)))
+ (dotimes (i (length components))
+ (if (integerp (setq ch (aref components i)))
+ (push (cons ch (describe-char-display pos ch))
+ component-chars)))
+ (setq component-chars (nreverse component-chars))
+ (format "composed to form \"%s\" (see below)"
+ (buffer-substring from to))))
+ (t
+ (let ((display (describe-char-display pos char)))
+ (if (display-graphic-p (selected-frame))
+ (if display
+ (concat
+ "by this font (glyph code)\n"
+ (format " %s (#x%02X)"
+ (first display) (second display)))
+ "no font available")
+ (if display
+ (format "terminal code %s" display)
+ "not encodable for terminal"))))))
+ ,＠(let ((face
+ (if (not (or disp-table-entry composition))
+ (cond
+ ;; XEmacs #### Implement this.
+; ((and show-trailing-whitespace
+; (save-excursion (goto-char pos)
+; (looking-at "[ \t]+$")))
+; 'trailing-whitespace)
+; ((and nobreak-char-display unicode (eq unicode '#xa0))
+; 'nobreak-space)
+; ((and nobreak-char-display unicode (eq unicode '#xad))
+; 'escape-glyph)
+ ((and (< char 32) (not (memq char '(9 10))))
+ 'escape-glyph)))))
+ (if face (list (list "hardcoded face"
+ `(insert-gui-button
+ (make-gui-button
+ ,(symbol-name face)))))))
+ ,＠(let ((unicodedata (and unicode
+ (describe-char-unicode-data unicode))))
+ (if unicodedata
+ (cons (list "Unicode data" " ") unicodedata)))))
+ (setq max-width (apply #'max (mapcar #'(lambda (x)
+ (if (cadr x) (length (car x)) 0))
+ item-list)))
+ ; (help-setup-xref nil (interactive-p))
+ (with-displaying-help-buffer
+ (lambda ()
+ (with-current-buffer standard-output
+ ; (set-buffer-multibyte multibyte-p)
+ (let ((formatter (format "%%%ds:" max-width)))
+ (dolist (elt item-list)
+ (when (cadr elt)
+ (insert (format formatter (car elt)))
+ (dolist (clm (cdr elt))
+ (if (consp clm)
+ (progn (insert " ") (eval clm))
+ (when (>= (+ (current-column)
+ (or (string-match "\n" clm)
+ (string-width clm))
+ 1)
+ (window-width))
+ (insert "\n")
+ (indent-to (1+ max-width)))
+ (insert " " clm)))
+ (insert "\n"))))
+
+ (when extents
+ (save-excursion
+ (goto-char (point-min))
+ (re-search-forward "character:[ \t\n]+")
+ (let* ((end (+ (point) (length char-description))))
+ (mapc #'(lambda (props)
+ (let ((o (make-extent (point) end)))
+ (while props
+ (set-extent-property o (car props) (nth 1 props))
+ (setq props (cddr props)))))
+ extents))))
+
+ ;; XEmacs change; don't give GUI- or TTY-specific detail about the
+ ;; display table entry, the #'specifier-instance call above dealt
+ ;; with that.
+ ; (when disp-table-entry ...)
+
+ ;; XEmacs; this doesn't work now.
+ (when composition
+ (insert "\nComposed")
+ (if (car composition)
+ (if (cadr composition)
+ (insert " with the surrounding characters \""
+ (car composition) "\" and \""
+ (cadr composition) "\"")
+ (insert " with the preceding character(s) \""
+ (car composition) "\""))
+ (if (cadr composition)
+ (insert " with the following character(s) \""
+ (cadr composition) "\"")))
+ (insert " by the rule:\n\t("
+ (mapconcat (lambda (x)
+ (format (if (consp x) "%S" "?%c") x))
+ (nth 2 composition)
+ " ")
+ ")")
+ (insert "\nThe component character(s) are displayed by ")
+ ;; XEmacs #### Once composition is in place, this should be
+ ;; a (font-instance-name (face-font-instance [...])) call.
+ (if (display-graphic-p (selected-frame))
+ (progn
+ (insert "these fonts (glyph codes):")
+ (dolist (elt component-chars)
+ (insert "\n " (car elt) ?:
+ (propertize " " 'display '(space :align-to 5))
+ (if (cdr elt)
+ (format "%s (#x%02X)" (cadr elt) (cddr elt))
+ "-- no font --"))))
+ (insert "these terminal codes:")
+ (dolist (elt component-chars)
+ (insert "\n " (car elt) ":"
+ (propertize " " 'display '(space :align-to 5))
+ (or (cdr elt) "-- not encodable --"))))
+ (insert "\nSee the variable `reference-point-alist' for "
+ "the meaning of the rule.\n"))
+
+ (if text-props-desc (insert text-props-desc))
+; (setq help-xref-stack-item (list 'help-insert-string (buffer-string)))
+ (toggle-read-only 1)
+ (print-help-return-message)))
+ (format "Describe %c" (char-after pos)))))
+
+(defalias 'describe-char-after 'describe-char)
+(make-obsolete 'describe-char-after 'describe-char "22.1")
+
+(provide 'descr-text)
+
+;; arch-tag: fc55a498-f3e9-4312-b5bd-98cc02480af1
+;;; descr-text.el ends here
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://calypso.tux.org/cgi-bin/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
Re: [A] carbon2: Respect carbon conventions with packages, init file; prefer Unix init files.
16 years, 11 months
Aidan Kehoe
Aidan Kehoe
Thanks!
Ar an t-ochtú lá de mí Meitheamh, scríobh Michael Sperber:
>
> Looks good to me.
>
> --
> Cheers =8-} Mike
> Friede, Völkerverständigung und überhaupt blabla
--
¿Dónde estará ahora mi sobrino Yoghurtu Nghé, que tuvo que huir
precipitadamente de la aldea por culpa de la escasez de rinocerontes?
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://calypso.tux.org/cgi-bin/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments