1 ;;; tinylibm.el --- Library of s(m)all macros or functions
5 ;; Copyright (C) 1995-2007 Jari Aalto
6 ;; Keywords: extensions
8 ;; Maintainer: Jari Aalto
10 ;; To get information on this program, call M-x tinylibm-version.
11 ;; Look at the code with folding.el
15 ;; This program is free software; you can redistribute it and/or modify it
16 ;; under the terms of the GNU General Public License as published by the Free
17 ;; Software Foundation; either version 2 of the License, or (at your option)
20 ;; This program is distributed in the hope that it will be useful, but
21 ;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
22 ;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
25 ;; You should have received a copy of the GNU General Public License
26 ;; along with program; see the file COPYING. If not, write to the
27 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
28 ;; Boston, MA 02110-1301, USA.
30 ;; Visit <http://www.gnu.org/copyleft/gpl.html> for more information
37 ;; Put this file on your Emacs-Lisp load path, add following into your
38 ;; ~/.emacs startup file
40 ;; (require 'tinylibm)
49 ;; This is lisp function library, package itself does nothing.
50 ;; It contains small functions or macros.
54 ;; You must not autoload this package; but always include
56 ;; (require 'tinylibm)
58 ;; You don't need any other require commands: all my other library
59 ;; functions get defined as well by using autoload. Repeat: you don't
60 ;; have to put these in your packages:
62 ;; (require 'tinylib) ;; leave this out
63 ;; (require 'tinyliby) ;; not needed either.
73 (require 'tinylibb) ;Backward compatible functions
77 ;;; ----------------------------------------------------------------------
79 (defun ti::function-car-test (symbol test-val &optional test-func)
80 "Test car of the SYMBOL against TEST-VAL with TEST-FUNC.
81 Function must be symbol, not a lambda form.
85 symbol yes, test succeeded
87 (if (and (not (sequencep symbol)) ;; list ?
88 (symbolp symbol) ;; chokes if not sequencep
91 ;; Eg. symbol-function 'car doesn't return list.
93 (listp (symbol-function symbol))
95 (funcall (or test-func 'car)
96 (symbol-function symbol))))
100 ;;; ----------------------------------------------------------------------
101 ;;; `indirect-function' unfortunately returns the symbol-function, not
102 ;;; the symbol name of the last function in the chain
104 (defun ti::defalias-p (symbol)
105 "If function SYMBOL is alias, return it's truename. Otw Return nil."
110 (if (or (sequencep symbol) ;lambda form ?
111 (not (symbolp symbol))
112 (not (fboundp symbol)))
114 (setq sym (symbol-function symbol))
115 (if (not (symbolp sym))
117 (while (and (symbolp sym) ;was alias, go into nesting levels
118 (fboundp sym)) ;must be function or user made mistake
120 (setq sym (symbol-function sym)))
124 ;;; ----------------------------------------------------------------------
126 (defun ti::subrp-p (symbol)
127 "Test if function SYMBOL is built-in function.
128 Emacs default test (subrp 'move-to-column) returns nil, but according to
129 the documentation string that function is built-in. This function also
130 checks the documentation string."
133 (or (subrp (symbol-function symbol))
136 (or (documentation-property symbol 'variable-documentation)
139 ;;; ----------------------------------------------------------------------
141 (defun ti::defmacro-p (symbol)
142 "Test if function SYMBOL is in fact macro, created with defmacro.
145 symbol this can be truename of the function if it was aliased
147 (ti::function-car-test symbol 'macro))
149 ;;; ----------------------------------------------------------------------
151 (defun ti::autoload-p (symbol)
152 "Test if function SYMBOL is in its autoload form.
153 Works with aliased symbols too.
156 symbol this can be truename of the function if it was aliased
158 ;; Get the REAL name if it is alias or use the func's SYMBOL name
159 (let* ((func (or (ti::defalias-p symbol) symbol)))
160 (ti::function-car-test func 'autoload)))
162 ;;; ----------------------------------------------------------------------
164 (defun ti::autoload-file (symbol)
165 "Return autoload filename of function SYMBOL.
166 You already have to have tested the symbol with `ti::autoload-p'
167 or otherwise result from this function is undefined.
170 string Name of the library where symbol autolaod point to."
171 ;; Get the REAL name if it is alias or use the func's SYMBOL name
172 (let* ((doc (prin1-to-string (symbol-function symbol))))
173 (when (and (stringp doc)
174 (string-match "autoload[ \t\"]+\\([^\"\r\n)]+\\)" doc))
175 (match-string 1 doc))))
177 ;;; ----------------------------------------------------------------------
179 (defun ti::lambda-p (symbol)
180 "Test if function SYMBOL was created with defsubst or is in lambda form.
183 symbol this can be truename of the function if it was aliased
185 (ti::function-car-test symbol 'lambda))
189 (defun ti::compatibility-advice-setup ()
190 "Define compatibility advices for function that have changed."
191 ;; Try to avoid loading advice.el.
192 ;; The tests from tinylib-ad.el are duplicated here.
196 (not (ti::emacs-p "20.2")))
200 "Tinylibm.el: tinylib-ad.el load reason: 1\n")))
202 (if (and (fboundp 'define-key-after) ;; Emacs function
206 (or (ti::function-args-p 'define-key-after) ""))))
211 "Tinylibm.el: tinylib-ad.el load reason: define-key-after\n")))
215 (string-match "noerr" (or (ti::function-args-p 'require) ""))))
219 "Tinylibm.el: tinylib-ad.el load reason: require\n")))
223 ;; It is unlikely that these are not in path, so this should not
225 (let ((exec-path exec-path))
226 (push "c:/windows" exec-path)
227 (push "c:/winnt" exec-path)
228 (null (or (executable-find "command")
229 (executable-find "cmd")))))
234 "Tinylibm.el: tinylib-ad.el load reason: executable-find\n")))
236 (when (and (fboundp 'read-char-exclusive)
239 (or (ti::function-args-p 'read-char-exclusive) ""))))
244 "Tinylibm.el: tinylib-ad.el load reason: read-char-exclusive")))
246 (when (or (assoc "-debug-init" command-switch-alist)
247 (assoc "--debug-init" command-switch-alist))
250 (when t ;; Enaled now.
251 ;; 2000-01-05 If compiled this file in Win32 XEmacs 21.2.32
252 ;; All the problems started. Make sure this is NOT compiled.
253 (let ((path (locate-library "tinylib-ad.elc")))
254 (when (and (stringp path)
255 (string-match "\\.elc$" path))
258 ** tinylibm.el: It is not recommend to compile tinylib-ad.el.
259 compiled file deleted %s" path))))
261 ;; Backward compatible functions
263 ;; #todo: EFS does something to `require' function. Should it be loaded
265 (if (and (string-match "reason: require" msg)
269 (unless (string= "" msg)
270 (require 'tinylib-ad)))))
272 (ti::compatibility-advice-setup)
275 (when (and (ti::xemacs-p)
276 (or (< emacs-major-version 20)
277 (and (eq emacs-major-version 20)
278 (< emacs-minor-version 3))))
280 tinylib.el: ** Ignore 'variable G3000' warnings. Corrected in XEmacs 20.3")))
286 (defconst ti:m-debug-buffer "*ti::d!!*"
287 "*Debug buffer where to write. Make a wrapper to use function ti::d!!
288 In your programs, like:
290 (defvar my-package-:debug nil
293 (defvar my-package-:debug-buffer \"*my-package*\"
294 \"Debug record buffer.\")
296 (defmacro my-package-debug (&rest args)
297 \"Record debug info.\"
299 (let* ( ;; write data to package private buffer.
300 (ti:m-debug-buffer my-package-:debug-buffer))
301 (if my-package-:debug
302 (ti::d!! (,@ args))))))
304 ;; this is how you use the debug capability in functions.
305 ;; You must enable debug with (setq my-package-:debug t)
307 (defun my-package-some-function ()
309 (my-package-debug \"here\" var1 win1ptr buffer \"\\n\" )
316 (defconst tinylibm-version
317 (substring "$Revision: 2.91 $" 11 16)
318 "Latest version number.")
320 (defconst tinylibm-version-id
321 "$Id: tinylibm.el,v 2.91 2007/05/07 10:50:07 jaalto Exp $"
322 "Latest modification time and version number.")
324 ;;; ----------------------------------------------------------------------
326 (defun tinylibm-version (&optional arg)
327 "Show version information. ARG will instruct to print message to echo area."
329 (ti::package-version-info "tinylibm.el" arg))
331 ;;; ----------------------------------------------------------------------
333 (defun tinylibm-submit-bug-report ()
336 (ti::package-submit-bug-report
339 '(tinylibm-version-id)))
342 ;;{{{ code: small FORMS
344 ;;; - To see what the'll become use for example:
345 ;;; (macroexpand '(decf x))
347 ;;; ----------------------------------------------------------------------
349 (defmacro-maybe ti::definteractive (&rest body)
350 "Define simple anonymous interactive function.
351 Function can take one optional argument 'arg'.
352 Very useful place where you can use this function is when you
353 want to define simple key functions
358 (message \"You gave arg: %s\" (ti::prefix-arg-to-text arg))))"
359 (` (function (lambda (&optional arg) (interactive "P") (,@ body)))))
361 ;;; ----------------------------------------------------------------------
363 (put 'nafboundp 'lisp-indent-function 2)
364 (defmacro ti::fboundp-check-autoload (function re &rest body)
365 "Execute body if certain condition is true.
367 a) If not FUNCTION is not bound.
371 a) function is bound in autoload state and
372 b) function's autoload definition matches regular expression RE
374 In short. Do BODY only if the autoload refer to file
375 matching RE. This is useful, if you define your own function that does
376 not exist in current Emacs, but may exist in newer releases. Suppose
380 ;; Make a forward declaration. Say it's in library
381 (autoload 'run-at-time \"tinylibxe\"))
383 in file tinylibxe.el:
385 (ti::fboundp-check-autoload 'run-at-time \"tinylibxe\"
387 ;; XEmacs does not have this, but it somebody made it autoload.
388 ;; The autoload refers to us, so we define the function.
389 ;; If the autoload referred somewhere else, then this form doesn't
390 ;; take in effect. Somebody else has actiated the autoload definition.
394 ((or (and (fboundp (, function))
395 (ti::autoload-p (, function))
398 (nth 1 (symbol-function (, function)))))
399 (not (fboundp (, function))))
402 ;;; ----------------------------------------------------------------------
404 (put 'ti::narrow-safe 'lisp-indent-function 2)
405 (put 'ti::narrow-safe 'edebug-form-spec '(body))
406 (defmacro ti::narrow-safe (beg end &rest body)
407 "Narrow temprarily to BEG END and do BODY.
408 This FORM preserves restriction and excursion with one command."
411 (narrow-to-region (, beg) (, end))
414 ;;; ----------------------------------------------------------------------
416 (put 'ti::narrow-to-paragraph 'lisp-indent-function 0)
417 (put 'ti::narrow-to-paragraph 'edebug-form-spec '(body))
418 (defmacro ti::narrow-to-paragraph (&rest body)
419 "Narrow to paragraph. Point must be already inside a paragraph."
422 (when (re-search-backward "^[ \t]*$" nil t)
425 (when (re-search-forward "^[ \t]*$" nil t)
426 (ti::narrow-safe beg (point)
429 ;;; ----------------------------------------------------------------------
430 ;;; Note that nconc works only if the initial
431 ;;; list is non-empty, that's why we have to initialize it in the
432 ;;; first time with if.
434 (defmacro ti::nconc (list x)
435 "Add to LIST element X. Like nconc, but can also add to empty list.
436 Using `nconc' is faster than `append'"
438 (nconc (, list) (list (, x))))))
440 ;;; ----------------------------------------------------------------------
442 ;;; (1 2) (cdr el) --> (2) ,this is list
443 ;;; (1) (cdr el) --> nil ,this too
444 ;;; (1 . 2) (cdr el) --> 2 ,listp returns nil
446 (defsubst ti::consp (elt)
447 "Test if ELT is in _really_ in format (X . X)."
448 (and (consp elt) ;must be some '(...) form
449 (null (listp (cdr elt)))))
451 ;;; ----------------------------------------------------------------------
453 (defsubst ti::listp (list)
454 "Test if the there _really_ is elements in the LIST.
455 A nil is not accepted as a true list."
456 (and (not (null list))
459 ;;; ----------------------------------------------------------------------
461 (put 'ti::when-package 'lisp-indent-function 2)
462 (put 'ti::when-package 'edebug-form-spec '(body))
463 (defmacro ti::when-package (feature &optional package &rest body)
464 "If FEATURE is present or if PACKAGE exist along `load-path' do BODY.
466 (when-package 'browse-url nil
467 (autoload 'browse-url-at-mouse \"browse-url\" \"\" t))"
469 (when (or (and (, feature)
470 (featurep (, feature)))
471 (locate-library (or (, package)
472 (symbol-name (, feature)))))
476 ;;; ----------------------------------------------------------------------
478 (put 'ti::with-require 'lisp-indent-function 2)
479 (put 'ti::with-require 'edebug-form-spec '(body))
480 (defmacro ti::with-require (feature &optional filename &rest body)
481 "Load FEATURE from FILENAME and execute BODY if feature is present.
482 E.g. try loading a package and only if load succeeds, execute BODY.
484 (with-feature 'browse-url nil
485 ;;; Setting the variables etc)"
487 (when (require (, feature) (, filename) 'noerr)
490 ;;; ----------------------------------------------------------------------
492 (put 'ti::with-time-this 'lisp-indent-function 1)
493 (put 'ti::with-time-this 'edebug-form-spec '(body))
494 (defmacro ti::with-time-this (function &rest body)
495 "Run FUNCTION after executing BODY and time execution.
496 Float time value in seconds is sent to FUNCTION.
498 (ti::with-time-this '(lambda (time) (message \"Secs %f\" time))
501 (let* ((Time-A (current-time))
506 (setq Time-B (current-time))
507 (setq Time-Diff (ti::date-time-difference Time-B Time-A 'float))
508 (funcall (, function) Time-Diff))))
510 ;;; ----------------------------------------------------------------------
512 (put 'ti::with-coding-system-raw-text 'lisp-indent-function 0)
513 (put 'ti::with-coding-system-raw-text 'edebug-form-spec '(body))
514 (defmacro ti::with-coding-system-raw-text (&rest body)
515 "Bind `coding-system-for-write' to Unix style raw write during BODY."
516 ;; #todo: 'raw-text is for Emacs, is this different in XEmacs?
517 (` (let* ((coding-system-for-write 'raw-text))
523 ;;; ----------------------------------------------------------------------
524 ;;; Great add to comint processess.
526 (defsubst ti::process-mark (&optional buffer)
527 "Return process mark for current buffer or optional BUFFER.
528 If there is no process mark, return nil."
529 (let* ((proc (get-buffer-process
533 (process-mark proc))))
535 ;;; ----------------------------------------------------------------------
537 (defmacro ti::verb ()
538 "Setq variable 'verb'.
539 The variable is set If interactive flag is set or if 'verb' variable is set.
540 This is usually the verbosity flag that allows printing messages.
544 The 'verb' is meant to be used in function when it decides if
545 should print verbose messages. This is different that using
546 simple (interactive-p) test, because (interactive-p) is only set
547 if the function is really called interactively. For complete
548 description why (interactive-p) est alone is not always the solution
549 refer to ftp://cs.uta.fi/pub/ssjaaa/ema-code.html under heading
550 that discusses about 'funtion and displaying messages'
554 You have to define variable 'verb' prior calling this macro,
555 preferably in function argument definition list.
559 (defun my-func (arg1 arg2 &optional verb)
561 ...do something, ask parameters)
562 (ti::verb) ;; set verbose if user calls us interactively
569 (setq verb (or verb (interactive-p)))))
571 ;;; ----------------------------------------------------------------------
573 (defsubst ti::pmin ()
575 (goto-char (point-min)))
577 ;;; ----------------------------------------------------------------------
579 (defsubst ti::pmax ()
581 (goto-char (point-max)))
583 ;;; ----------------------------------------------------------------------
585 (defmacro-maybe int-to-float (nbr)
586 "Convert integer NBR to float."
587 (` (read (concat (int-to-string (, nbr)) ".0"))))
589 ;;; ----------------------------------------------------------------------
590 ;;; see also: (dotimes (var 5) ..
592 (put 'ti::dotimes 'lisp-indent-function 3)
593 (defmacro ti::dotimes (var beg end &rest body)
594 "Loop using VAR from BEG to END and do BODY."
595 (` (loop for (, var) from (, beg) to (, end)
600 ;;; ----------------------------------------------------------------------
602 (defmacro ti::funcall (func-sym &rest args)
603 "Call FUNC-SYM with ARGS. Like funcall, but quiet byte compiler.
607 Byte Compiler isn't very smart when it comes to knowing if
608 symbols exist or not. If you have following statement in your function,
609 it still complaints that the function \"is not known\"
611 (if (fboundp 'some-non-existing-func)
612 (some-non-existing-func arg1 arg2 ...))
616 (if (fboundp 'some-non-existing-func)
617 (ti::funcall 'some-non-existing-func arg1 arg2 ...)
619 to get rid of the unnecessary warning.
623 You _cannot_ use ti::funcall if the function is in autoload state, because
624 `symbol-function' doesn't return a function to call. Rearrange
625 code so that you do (require 'package) or (ti::autoload-p func) test before
628 (let* ((func (, func-sym)))
629 (when (fboundp (, func-sym))
630 (apply func (,@ args) nil)))))
632 ;;; (apply (symbol-function (, func-sym)) (,@ args) nil)
634 ;;; ----------------------------------------------------------------------
635 ;;; Emacs distribution, sun-fns.el -- Jeff Peck
637 (defun-maybe logtest (x y)
638 "Tinylibm: True if any bits set in X are also set in Y.
639 Just like the Common Lisp function of the same name."
640 (not (zerop (logand x y))))
642 ;;; ----------------------------------------------------------------------
644 (defun-maybe bin-string-to-int (8bit-string)
645 "Convert 8BIT-STRING string to integer."
646 (let* ((list '(128 64 32 16 8 4 2 1))
650 (if (not (string= "0" (substring 8bit-string i (1+ i))))
651 (setq int (+ int (nth i list) )))
655 ;;; ----------------------------------------------------------------------
657 (defun-maybe int-to-bin-string (n &optional length)
658 "Convert integer N to bit string (LENGTH, default 8)."
661 (s (make-string len ?0)))
663 (if (not (zerop (logand n (ash 1 i))))
664 (aset s (- len (1+ i)) ?1))
668 ;;; ----------------------------------------------------------------------
670 (defun-maybe int-to-hex-string (n &optional separator pad)
671 "Convert integer N to hex string. SEPARATOR between hunks is \"\".
672 PAD says to padd hex string with leading zeroes."
676 (function (lambda (x)
677 (setq x (format "%X" (logand x 255)))
686 ;;; ----------------------------------------------------------------------
688 (defun-maybe int-to-oct-string (n &optional separator)
689 "Convert integer N into Octal. SEPARATOR between hunks is \"\"."
693 (function (lambda (x)
694 (setq x (format "%o" (logand x 511)))
695 (if (= 1 (length x)) (concat "00" x)
696 (if (= 2 (length x)) (concat "0" x) x))))
697 (list (ash n -27) (ash n -18) (ash n -9) n)
700 ;;; ----------------------------------------------------------------------
702 (defun radix (str base)
703 "Convert STR according to BASE."
704 (let ((chars "0123456789abcdefghijklmnopqrstuvwxyz")
709 (setq i (string-match (make-string 1 c) chars))
710 (if (>= (or i 65536) base)
711 (error "%c illegal in base %d" c base))
712 (setq n (+ (* n base) i)))
716 ;;; ----------------------------------------------------------------------
718 (defun-maybe bin-to-int (str)
719 "Convert STR into binary."
722 ;;; ----------------------------------------------------------------------
724 (defun-maybe oct-to-int (str)
725 "Convert STR into octal."
728 ;;; ----------------------------------------------------------------------
730 (defun hex-to-int (str)
731 "Convert STR into hex."
732 (if (string-match "\\`0x" str)
733 (setq str (substring str 2)))
736 ;;; ----------------------------------------------------------------------
738 (defun-maybe int-to-net (float)
739 "Decode packed FLOAT 32 bit IP addresses."
740 (format "%d.%d.%d.%d"
741 (truncate (% float 256))
742 (truncate (% (/ float 256.0) 256))
743 (truncate (% (/ float (* 256.0 256.0)) 256))
744 (truncate (% (/ float (* 256.0 256.0 256.0)) 256))))
746 ;;; ----------------------------------------------------------------------
748 (defun-maybe rmac (string)
749 "Decode STRING x-mac-creator and x-mac-type numbers."
751 (setq string (format "%X" string)))
754 (while (< i (length string))
759 ;; EWas call to 'rhex'
760 (hex-to-int (concat (make-string 1 (aref string i))
761 (make-string 1 (aref string (1+ i)))))))
765 ;;; ----------------------------------------------------------------------
767 (defun-maybe ctime (time)
768 "Print a time_t TIME."
769 (if (and (stringp time) (string-match "\\`[0-9]+\\'" time))
770 (setq time (string-to-number (concat time ".0"))))
771 (let* ((top (floor (/ time (ash 1 16))))
772 ;; (bot (floor (mod time (1- (ash 1 16)))))
773 (bot (floor (- time (* (ash 1 16) (float top))))))
774 (current-time-string (cons top bot))))
776 ;;; ----------------------------------------------------------------------
779 "Random number in [0 .. N]."
784 (abs (% (random) n)))))
786 ;;; ----------------------------------------------------------------------
788 (defsubst-maybe rand1 (n)
789 "Random number [1 .. N]."
792 ;;; ----------------------------------------------------------------------
794 (defun-maybe randij (i j)
795 "Random number [I .. J]."
797 ((< i j) (+ i (rand0 (1+ (- j i)))))
799 ((> i j) (+ j (rand0 (1+ (- i j)))))
801 (error "randij wierdness %s %s"
803 (ti::string-value j)))))
805 ;;; ----------------------------------------------------------------------
807 (defun ti::string-value (x)
808 "Return a string with some reasonable print-representation of X.
809 If X is an integer, it is interpreted as an integer rather than
810 a character: (ti::string-value 65) ==> \"65\" not \"A\"."
813 ((symbolp x) (symbol-name x))
814 ((numberp x) (int-to-string x))
815 (t (prin1-to-string x))))
817 ;;; ----------------------------------------------------------------------
819 (defun ti::prin1-mapconcat (separator &rest args)
820 "Cats elements separated by single space or with SEPARATOR.
821 The ARGS can be anything.
824 (print1cat nil buffer frame overlay list)"
827 (setq separator " "))
839 (concat "%d" separator)
844 (concat "%s" separator)
849 (concat "'%s" separator )
859 (concat "%s" separator)
864 ;;; ----------------------------------------------------------------------
865 ;;; - The world's oldest way to debug program by inserting breakpoints...
867 (defmacro ti::d! (&rest args)
868 "Debug. Show any ARGS and wait for keypress."
871 (read-from-minibuffer (ti::prin1-mapconcat "|" (,@ args)))))))
873 ;;; ----------------------------------------------------------------------
874 ;;; - This logs to buffer, when you can't display values, e.g. in loop
875 ;;; or while you're in minibuffer and reading input.
876 ;;; - see tinydiff.el how to use this productively.
878 (defmacro ti::d!! (&rest args)
879 "Stream debug. Record any information in ARGS to debug buffer.
884 (ti::append-to-buffer
885 (get-buffer-create ti:m-debug-buffer)
887 (ti::prin1-mapconcat "|" (,@ args)))))))
889 ;;; ----------------------------------------------------------------------
891 (defsubst ti::string-left (str count)
892 "Use STR and read COUNT chars from left.
893 If the COUNT exeeds string length or is zero, whole string is returned."
895 (substring str 0 (min (length str) count))
898 ;;; ----------------------------------------------------------------------
899 ;;; - You can do this with negative argument to substring, but if you exceed
900 ;;; the string len, substring will barf and quit with error.
901 ;;; - This one will never call 'error'.
903 (defsubst ti::string-right (str count)
904 "Use STR and read COUNT chars from right.
905 If the COUNT exeeds string length or is zero, whole string is returned."
906 (let* ((pos (- (length str) count)))
908 (substring str (- 0 count))
911 ;;; ----------------------------------------------------------------------
913 (defsubst ti::string-match-case (re str &optional case-fold start)
914 "Do local case sensitive match.
916 RE See `string-match'
917 STR See `string-match'
918 CASE-FOLD Value of `case-fold-search', nil means sensitive.
919 START See `string-match'"
920 (let ((case-fold-search case-fold))
921 (string-match re str start)))
923 ;;; ----------------------------------------------------------------------
925 (defsubst ti::month-list ()
926 "Return LIST: month names in short format."
927 (list "Jan" "Feb" "Mar" "Apr" "May" "Jun"
928 "Jul" "Aug" "Sep" "Oct" "Nov" "Dec"))
930 ;;; ----------------------------------------------------------------------
932 (defun ti::month-list-regexp (&optional cat-str)
933 "Return month regexp separated by ' \\\\|' or CAT-STR.
934 There is intentional space, since short month name is supposed to
935 follow something else."
937 (mapconcat 'concat (ti::month-list) (or cat-str " \\|"))))
938 ;; The last item must be handled separately
942 ;;; ----------------------------------------------------------------------
944 (defsubst ti::month-mm-alist () ;mm = month first
945 "Short month names in alist form: ((\"Jan\" 1) ..)."
946 '( ("Jan" . 1) ("Feb" . 2) ("Mar" . 3)
947 ("Apr" . 4) ("May" . 5) ("Jun" . 6)
948 ("Jul" . 7) ("Aug" . 8) ("Sep" . 9)
949 ("Oct" . 10) ("Nov" . 11) ("Dec" . 12)))
951 ;;; ----------------------------------------------------------------------
953 (defsubst ti::month-nn-alist () ;nn = nbr first
954 "Short month names in alist form: ((1 \"Jan\") ..)."
955 '( (1 . "Jan") (2 . "Feb") (3 . "Mar")
956 (4 . "Apr") (5 . "May") (6 . "Jun")
957 (7 . "Jul") (8 . "Aug") (9 . "Sep")
958 (10 . "Oct") (11 . "Nov") (12 . "Dec")))
960 ;;; ----------------------------------------------------------------------
962 (defsubst ti::month-to-number (month &optional zero-padded)
963 "Convert MONTH, 3 character initcap month name e.g. `Jan' to number."
964 (let ((nbr (cdr-safe (assoc month (ti::month-mm-alist)))))
969 ;;; ----------------------------------------------------------------------
971 (defsubst ti::month-to-0number (month)
972 "Convert MONTH, 3 character capitalized month name e.g. `Jan' to 01."
973 (format "%02d" (cdr (assoc month (ti::month-mm-alist)))))
975 ;;; ----------------------------------------------------------------------
977 (defsubst ti::number-to-month (number)
978 "Convert NUMBER to month, 3 character capitalized name e.g. `Jan'."
979 (cdr-safe (assoc number (ti::month-nn-alist))))
981 ;;; ----------------------------------------------------------------------
983 (defsubst ti::date-eu-list ()
984 "Return list: European date list."
985 '("Mon" "Tue" "Wed" "Thu" "Fri" "Sat" "Sun"))
987 ;;; ----------------------------------------------------------------------
989 (defsubst ti::date-us-list ()
990 "Return list: US date list."
991 '("Sun" "Mon" "Tue" "Wed" "Thu" "Fri" "Sat"))
993 ;;; ----------------------------------------------------------------------
995 (defun ti::date-list-regexp (&optional cat-str)
996 "Return date regexp combined with CAT-STR.
997 There is intentional SPACE after each date.
1000 CAT-STR default is \" \\\\|\""
1002 (mapconcat 'concat (ti::date-eu-list) (or cat-str " \\|"))))
1003 ;; The last item must be handled separately
1007 ;;; ----------------------------------------------------------------------
1009 ;;; In XEmacs20, you can't use following
1010 ;;; (memq ch '(?a ?b ?c ?d ?e ?f)), because 'eq' test against
1011 ;;; characters is wrong.
1013 ;;; Neither is this format recommended.
1014 ;;; (memq (char-int ch) (mapcar 'char-int '(?a ?b ?c ?d ?e ?f)))
1016 ;;; cl's (member* ch '(?a ?b) :test 'char=)
1018 (defsubst ti::char-in-list-case (char list)
1019 "If CHAR can be found in LIST, return a pointer to it.
1020 The match is case sensitive."
1022 (let* (case-fold-search)
1023 (member* char list :test 'char=))))
1025 ;;; ----------------------------------------------------------------------
1026 ;;; #todo: read-char-exclusive?
1028 (defsubst ti::read-char-safe (&optional prompt)
1029 "Wait for character until given and ignore all other events with PROMPT.
1030 The `read-char' command chokes if mouse is moved while reading input.
1031 This function returns 'ignore if the `read-char' couldn't read answer.
1032 Otherwise it returns normal character.
1036 The cursor is not in the echo area when character is read. This
1037 may be confusing to user if you read multiple characters.
1041 `ti::read-char-safe-until'
1042 `read-char-exclusive'
1047 'ignore if read failed due to non-char event."
1050 (message (or prompt "")) ;prevent echoing keycodes...
1051 (discard-input) ;this is a must before we read
1054 ;; Emacs: this is no-op
1055 ;; XEmacs19.14: char-int doesn't exist.
1056 ;; XEmacs20: read-char has changed, it does not return
1057 ;; int, but a character type, and we need conversion
1063 ;;; ----------------------------------------------------------------------
1064 ;;; Note: see function `read-char-exclusive' in never Emacs versions, 19.29+
1065 ;;; Hm, It does not implement LIST of choices to accept.
1067 (defun ti::read-char-safe-until (&optional prompt list)
1068 "Read character until given. Discards any events that are not characters.
1072 PROMPT text displayed when asking for character
1073 LIST list of character choices. The prompting won't stop until one of
1074 the list memebers has been selected.
1078 character character type"
1082 (while (symbolp (setq ch (ti::read-char-safe prompt)))))
1084 ;; Check args or we're thrown on planetary ride, which never ends
1085 (if (or (not (ti::listp list))
1086 ;; eshell-2.4.1/esh-mode.el mistakenly defines characterp
1087 ;; make sure this function is always correct.
1089 (ti::compat-character-define-macro 'characterp 'integerp))
1090 (not (characterp (car list))))
1091 (error "Invalid list, must contain character in LIST %s" list))
1092 ;; We don't have to do character conversion, because they are
1094 (while (or (symbolp (setq ch (ti::read-char-safe prompt)))
1096 (not (ti::char-in-list-case ch list))))))
1100 ;;; ----------------------------------------------------------------------
1102 (defsubst ti::remove-properties (string)
1103 "Remove properties from STRING. Modifies STRING permanently.
1105 string with no properties."
1106 (when (stringp string)
1107 (set-text-properties 0 (length string) nil string)
1110 ;;; ----------------------------------------------------------------------
1111 ;;; - this is from fsf-translate-keys.el
1113 (defmacro ti::applycar (function-form list-form)
1114 "Like mapcar, but does (apply FUNCTION-FORM (car LIST-FORM)).
1115 Instead of (funcall FUNCTION (car LIST)). This is very useful for
1116 invoking some function with many different sets of arguments.
1120 (ti::applycar 'global-set-key
1122 ([f12] repeat-complex-command) ; Again L2
1123 ([f14] undo) ; Undo L4
1124 ([f16] copy-region-as-kill) ; Copy L6
1125 ([f18] yank) ; Paste L8
1126 ([f20] kill-region))) ; Cut L10
1128 --> (nil nil nil nil nil) ;; global - set - key returns 'nil
1130 (ti::applycar (lambda (a b) (list b a)) ;; swaps arguments
1134 (let ((spec-name (gensym)))
1135 (` (mapcar (lambda ((, spec-name))
1136 (apply (, function-form) (, spec-name)) )
1139 ;;; ----------------------------------------------------------------------
1141 (defsubst ti::add-command-line-arg (arg &optional func)
1142 "Add ARG into `command-switch-alist' if it's not already there.
1143 This inhibits argument to be treated as filename.
1145 Optional FUNC is called when arg is found. Default FUNC used is 'ignore."
1146 ;; make sure it's not there already
1147 (or (assoc arg command-switch-alist)
1148 (setq command-switch-alist
1149 (cons (cons arg (or func 'ignore))
1150 command-switch-alist))))
1153 ;;{{{ tests; small ones
1155 ;;; ----------------------------------------------------------------------
1157 (defsubst ti::buffer-modified-p (&optional buffer)
1158 "Same as `buffer-modified-p' but acceps arg BUFFER."
1161 (with-current-buffer buffer
1162 (buffer-modified-p))))
1164 ;;; ----------------------------------------------------------------------
1166 (defsubst ti::buffer-minibuffer-1-p ()
1167 "Test if current buffer is minibuffer."
1168 (window-minibuffer-p (selected-window)))
1170 ;;; ----------------------------------------------------------------------
1172 (defsubst ti::buffer-minibuffer-p (&optional buffer)
1173 "Check if BUFFER is minibuffer. Defaults to current buffer."
1176 (buffer-live-p buffer))
1177 (with-current-buffer buffer
1178 (ti::buffer-minibuffer-1-p)))
1180 (ti::buffer-minibuffer-1-p))))
1182 ;;; ----------------------------------------------------------------------
1184 (defsubst ti::first-line-p ()
1185 "Check if cursor is at first line"
1190 ;;; ----------------------------------------------------------------------
1192 (defsubst ti::last-line-p ()
1193 "Check if cursor is at last line"
1198 ;;; ----------------------------------------------------------------------
1200 (defsubst ti::buffer-narrowed-p ()
1201 "Check if buffer is narrowed."
1202 (not (eq 1 (point-min))))
1204 ;;; ----------------------------------------------------------------------
1206 (defun ti::buffer-empty-p (&optional buffer)
1207 "Check if BUFFER is empty.
1208 Buffer is considered empty if
1210 a) real `point-min' == `point-max'
1211 b) or it contains only whitespace characters.
1215 nil buffer contains something
1217 'empty contains only whitespace"
1218 (with-current-buffer (or buffer (current-buffer))
1219 (if (eq (point-min-marker) (point-max-marker))
1222 (if (re-search-forward "[^ \n\t]" nil t)
1226 ;;; ----------------------------------------------------------------------
1228 (defun ti::ck-maybe-activate (&optional type mode message)
1229 "Activate keybinding conversion if used Emacs needs it.
1230 Call `ti::ck-advice-control' with parameter mode if key conversion needed.
1231 This ensures that binding work in any Emacs (XEmacs and Emacs).
1232 If you only use STRING bindings only use string notation
1234 (global-set-key \"\\C-c\\C-f\" ...)
1236 then you don't need this function.
1240 Informs how you have written the keybindings. The 'xemacs binding
1241 type is already supported by 19.33+ Emacs releases, but if you want your
1242 packages be backward compatible you want to call this functions prior
1243 bind definitions. Note: if you call this function with parameter
1244 'xemacs and ey definitions being bound are done in Emacs that supports
1245 XEmacs style bindings, this function is no-op.
1247 # The Control-a binding is stylistically exploded due to
1250 'emacs Your bindings are like [?\\C - a] and [f10]
1251 'emacs-mouse You use Emacs specific binding [mouse-1]
1252 'xemacs Your bindings are like [(control ?a)] and [(f10)]
1253 'xemacs-mouse You use XEmacs specific binding [(button1)]
1257 nil You pass this argument bfore you start defining keys
1258 'disable You pass this, when you have finished.
1262 Message you want to display if conversion is activated.
1266 (ti::ck-maybe-activate 'emacs) ;; turn conversion on in Xemacs
1267 (define-key [f1] 'xxx-function-call)
1268 <other key definitions ...>
1269 (ti::ck-maybe-activate 'emacs 'disable) ;; conversion off
1273 It is recommended that you write using the 'xemacs style, which
1274 is also supported in later Emacs releases 19.30+. If you do so,
1275 then calling this function is no-op in those Emacsen that support
1276 XEmacs style and you save the call to tinyck.el package.
1280 t conversion activated
1282 (let* ((emacs-major (ti::emacs-p))
1283 (common (or (ti::xemacs-p)
1286 ;; 19.34 Added XEmacs styled binding support
1288 (> emacs-minor-version 33)))))
1290 ;; If there is mouse button bindings, then we have to use the conversion.
1291 ;; Turn off "compatibility" flag between Emacs and XEmacs
1293 (if (memq type '(xemacs-mouse emacs-mouse))
1296 ;;; (eval-and-compile (ti::d! type common emacs-major message))
1300 ((memq type '(xemacs xemacs-mouse))
1301 (when (ti::emacs-p) ;XEmacs bindings and we're in Emacs
1302 (if message (message message))
1303 (ti::ck-advice-control mode)
1305 ((memq type '(emacs emacs-mouse))
1306 (when (ti::xemacs-p) ;Emacs bindings and we're in XEmacs
1307 (if message (message message))
1308 (ti::ck-advice-control mode)
1311 (error "Unknown type %s" type mode))))))
1313 ;;; ----------------------------------------------------------------------
1314 ;;; See register.el::insert-register
1316 (defsubst ti::register-live-p (char)
1317 "Test if register CHAR contain valid window configuration or mark."
1318 (let ((val (get-register char)))
1319 (if (or (consp val) ;window config
1320 (and (markerp val) ;mark
1321 (marker-buffer val))) ;not killed, reverted
1325 ;;; ----------------------------------------------------------------------
1327 (defsubst ti::file-dos-p ()
1328 "Check if there is anywhere \\r$ in the buffer."
1331 (re-search-forward "\r$" nil t)))
1333 ;;; ----------------------------------------------------------------------
1335 (defsubst ti::space-p (char)
1336 "Return t if character CHAR is space or tab."
1337 (or (char= char ?\t)
1340 ;;; ----------------------------------------------------------------------
1342 (defun ti::compat-face-p (face-symbol)
1343 "XEmacs ad Emacs compatibility, Check if the FACE-SYMBOL exists."
1345 ((fboundp 'find-face)
1346 (ti::funcall 'find-face face-symbol))
1347 ((fboundp 'face-list)
1348 (memq face-symbol (ti::funcall 'face-list)))))
1350 ;;; ----------------------------------------------------------------------
1352 (defun ti::color-type ()
1353 "Read Frame background and return `background-mode: 'dark 'light."
1354 ;; (frame-parameter 'display-type)
1355 ;; (frame-parameters (selected-frame))
1356 ;; We can't read frame information when we have no visible window.
1357 (frame-parameter (selected-frame) 'background-mode))
1359 ;;; ----------------------------------------------------------------------
1360 ;;; Emacs 21.3+ includes this, but is it not the same as here
1361 ;;; (color-supported-p COLOR FRAME &optional BACKGROUND-P)
1362 (defun ti::colors-supported-p ()
1363 "Check if colours can be used (that thay can be displayed)."
1366 (or ;; (and (fboundp 'x-display-color-p)
1367 ;; (ti::funcall 'x-display-color-p))
1368 (ti::compat-window-system) ;; Under 21, no colors in tty
1369 (> emacs-major-version 20)))
1371 (or (and (fboundp 'device-class)
1372 ;; x-display-color-p can only be called in X, otw gives error
1373 (eq 'color (ti::funcall 'device-class)))
1374 ;; #todo: Can I consider font-lock support for TTY as
1375 ;; color support? Here I assume yes.
1376 (> emacs-major-version 19) ;XEmacs 20+ does tty
1377 (and (eq emacs-major-version 19) ;> 19.15 does too
1378 (> emacs-minor-version 14))))))
1380 ;;; ----------------------------------------------------------------------
1382 (defun ti::color-lighter (color &optional percentage)
1383 "From base COLOR, make it integer PERCENTAGE, default 5, lighter."
1385 (setq percentage 5))
1386 (let* ((components (x-color-values color))
1388 (mapcar (lambda (comp)
1389 (setq comp (/ comp 256))
1390 (incf comp (/ (* percentage 256) 100))
1397 (apply 'format "#%02x%02x%02x" new-components)))
1399 ;;; ----------------------------------------------------------------------
1401 (defun ti::overlay-supported-p ()
1402 "Check if overlays are supported."
1404 ;; XEmacs has overlay emulation package, but only the 20.x
1405 ;; version works right.
1406 (and (ti::xemacs-p "20.0" )
1407 (or (featurep 'overlay)
1408 (load "overlay" 'noerr))))) ;; will return t if load was ok
1410 ;;; ----------------------------------------------------------------------
1412 (defun ti::idle-timer-supported-p ()
1413 "Check if reliable idle timers are supported."
1414 (and (fboundp 'run-with-idle-timer)
1415 (or (ti::emacs-p) ;; Idle timers work in all Emacs versions Win32/Unix
1416 ;; Only work in XEmacs under 21.2+
1417 (ti::xemacs-p "21.2"))))
1420 ;;{{{ misc, matching
1422 ;;; - The functions must be here, because defsubsts must be defined
1427 ;;; ----------------------------------------------------------------------
1428 ;;; The old replace-match doesn't have support for subexpressions.
1429 ;;; 19.28: (replace-match NEWTEXT &optional FIXEDCASE LITERAL STRING)
1430 ;;; 19.34: (replace-match NEWTEXT &optional FIXEDCASE LITERAL STRING SUBEXP)
1432 (defun ti::replace-match (level &optional replace string)
1433 "Kill match from buffer at submatch LEVEL or replace with REPLACE.
1434 Point sits after the replaced or killed area.
1438 LEVEL Replace submatch position. 0 is full match
1439 REPLACE [optional] The replce string
1440 STRING [optional] If match was against string, supply the string here,
1441 like in (ti::replace-match 1 replace str)
1445 nil if match at LEVEL doesn't exist.
1446 str if string was given"
1450 (delete-region (match-beginning level) (match-end level))
1451 ;; I think emacs has bug, because cursor does not sit at
1452 ;; match-beginning if I delete that region, instead it is off +1
1453 ;; --> force it to right place
1455 (goto-char (match-beginning level))
1458 (when (match-end level) ;Handle string case
1460 (substring string 0 (match-beginning level))
1461 (if replace replace "")
1462 (substring string (match-end level))))))
1464 ;;; ----------------------------------------------------------------------
1466 (defsubst ti::buffer-kill-control-characters ()
1467 "Kill all control characters from the buffer."
1471 ;; Excludes tab,ff,cr,lf.
1472 (while (re-search-forward "[\000-\010\016-\037]+" nil t)
1473 (ti::replace-match 0))))
1475 ;;; ----------------------------------------------------------------------
1477 (defsubst ti::string-match (re level str)
1478 "Return RE match at LEVEL from STR. Nil if no match at level."
1479 (if (string-match re str)
1480 (match-string level str)))
1482 ;;; ----------------------------------------------------------------------
1484 (defsubst ti::buffer-match (re level)
1485 "Return string matching RE from _buffer_ at LEVEL. Use `looking-at'.
1486 Nil if no match at level."
1488 (match-string level)))
1490 ) ;; eval-and-compile
1495 ;;; ----------------------------------------------------------------------
1497 (defsubst ti::selective-display-line-p ()
1498 "Check if this line is collapsed with selective display.
1499 Note: `selective-display' variable is usually t and the line contains \\r."
1502 (looking-at ".*\r")))
1504 ;;; ----------------------------------------------------------------------
1506 (defsubst ti::bool-p (var)
1507 "Test if VAR is nil or t."
1508 (or (eq var nil) (eq var t)))
1510 ;;; ----------------------------------------------------------------------
1512 (defmacro ti::print-p (ch)
1513 "Determines if character CH can be printed normally.
1514 CH can be anything and this function won't choke. The \\t \\r \\n and \\f
1515 codes are considered printable.
1521 (` (if (and (not (null (, ch))) ;it must not be nil
1522 (or (ti::char-in-list-case (, ch) '(?\t ?\n ?\r ?\f))
1523 ;; esh-mode.el makes wrong definition of
1524 ;; `char-int'. Fix it.
1526 (ti::compat-character-define-macro 'char-int 'identity))
1528 (> (char-int (, ch)) 31)
1529 (< (char-int (, ch)) 127))))
1532 ;;; ----------------------------------------------------------------------
1534 (defun ti::char-case-p (char)
1535 "Check if character is uppercase or lowercase.
1540 nbr if character isn't in set [A-Za-z] it returns CHAR."
1542 ((and (>= (char-int char) 97) (<= (char-int char) 122))
1544 ((and (>= (char-int char) 65) (<= (char-int char) 90))
1549 ;;; ----------------------------------------------------------------------
1551 (defsubst ti::nil-p (var)
1552 "Test if VAR is empty.
1553 Variable with only whitespaces [ \\f\\t\\r\\n]* is considered empty too.
1556 (if (ti::nil-p (setq answer (read-from-minibuffer \"give dime? \")))
1557 (message \"No fruit juice for you then.\"))"
1560 (or (string= var "")
1561 (not (string-match "[^ \t\f\r\n]" var))))))
1563 ;;; ----------------------------------------------------------------------
1564 ;;; #todo: XEmacs: pos-visible-in-window-p ?
1565 (defsubst ti::window-pmin-visible-p ()
1566 "Check if the `point-min' is visible in current window."
1567 (eq (window-start) (point-min)))
1569 ;;; ----------------------------------------------------------------------
1571 (defmacro ti::window-pmax-visible-p ()
1572 "Check if the `point-max' is visible in current window."
1573 (eq (window-end) (point-max)))
1575 ;;; ----------------------------------------------------------------------
1576 ;;; Window pmin == the area of buffer that user sees, top line
1578 (defun ti::window-pmax-line-p ()
1579 "Check if cursor is on the same line as window's `point-max'."
1583 (setq point (point))
1584 (goto-char (window-end))
1585 ;; a) if the last line DOES NOT exceed the window len; then the
1586 ;; (window-end) is in next unvisible line. --> backward char
1587 ;; brings it to previous line
1588 ;; b) if the last line exceed the window len; then the
1589 ;; (window-end) puts cursor at the last line. --> backward-char
1593 (eq (point) point))))
1595 ;;; ----------------------------------------------------------------------
1597 (defsubst ti::window-pmin-line-p ()
1598 "Check if cursor is on the same line as window's `point-min'."
1601 ;; The 1- is due to fact that there is NEWLINE, where C-e command
1602 ;; does not ever go.
1603 (eq (point) (window-start))))
1605 ;;; ----------------------------------------------------------------------
1607 (defun ti::window-pmax-line-bol (&optional eol-point)
1608 "Return window's last line's beginnning of point or EOL-POINT."
1610 ;; This is past of visible window, that why we go up one line
1611 (goto-char (window-end))
1615 (beginning-of-line))
1618 ;;; ----------------------------------------------------------------------
1620 (defun ti::window-middle-line ()
1621 "Computes middle line nbr in current window."
1622 (let* ((win-min (count-lines (point-min) (window-start)))
1623 (win-max (count-lines (point-min) (window-end)))
1624 (middle (+ win-min (/ (1+ (- win-max win-min)) 2))))
1627 ;;; ----------------------------------------------------------------------
1628 ;;; Ideas from eldoc.el
1630 (defun ti::no-action-in-progress-p (mode)
1631 "Return t if there is no action currently in progress.
1632 This means that following cases indicate that action is in progress
1633 and it should not be interfered.
1635 o if cursor is in the minibuffer
1636 o keyboard macro is executing
1641 This says that the function that calls us is currently run
1642 by an timer functin (19.34+)
1645 Same as above; but this time calling command is running in post hook.
1647 This function is usually called from background processes that are
1648 run by timers or post-command*hook functions when they want to print
1649 something in the echo area."
1651 (not executing-kbd-macro)
1652 ;; Having this mode operate in an active minibuffer/echo area causes
1653 ;; interference with what's going on there.
1654 (not cursor-in-echo-area)
1655 ;; Somehow this isn't quite doing what I want. If tested with C-x
1656 ;; C-f open, it still goes on loading while this function should
1657 ;; tell "user is in minibuffer"
1658 (not (eq (selected-window) (minibuffer-window)))
1659 ;; This has been disabled because user may move away from the
1660 ;; minibuffer but the minibuffer still stays active there. -->
1661 ;; the previous test already tells if user is really doing
1662 ;; something in minibuffer
1663 ;;; (not (minibuffer-window-active-p (minibuffer-window)))
1667 ;; If this-command is non-nil while running via an idle
1668 ;; timer, we're still in the middle of executing a command,
1669 ;; e.g. a query-replace where it would be annoying to
1670 ;; overwrite the echo area.
1671 (and (not this-command)
1672 (symbolp last-command)))
1673 ((eq mode 'post-command)
1674 ;; If this-command is non-nil while running via an idle
1675 ;; timer, we're still in the middle of executing a command,
1676 ;; e.g. a query-replace where it would be annoying to
1677 ;; overwrite the echo area.
1678 (and (symbolp this-command)
1684 ;;; ----------------------------------------------------------------------
1685 ;;; Should return the same as goto-line, does it always ?
1687 (defun ti::current-line-number (&optional pmin)
1688 "Return current line number from the beginning of buffer.
1689 If ti::pmin is non-nil the `point-min' is used for starting point, this
1690 is useful e.g. for narrowed case. Normally returns true line number.
1692 This function counts the number of \\n chartacters, so it will
1693 return right count even in folding/outline buffers where selective
1694 display is used. Using command `count-lines' would return false value.
1696 Lines are counted from 1..x"
1697 ;; - always use line beginning as reference
1698 ;; - The count-lines returns 0 for 1st line --> 1+
1699 (1+ (count-char-in-region
1703 (line-beginning-position)
1706 ;;; ----------------------------------------------------------------------
1708 (defsubst ti::read-current-line (&optional point)
1709 "Retun whole line or portion of line, starting from POINT to the eol."
1715 (line-beginning-position))
1716 (line-end-position))))
1718 ;;; ----------------------------------------------------------------------
1721 (defsubst ti::line-length (&optional point)
1722 "Length of current line. Optionally from POINT."
1724 (if point (goto-char point))
1728 ;;; ----------------------------------------------------------------------
1730 (defsubst ti::line-wrap-p ()
1731 "Check if line wraps. ie. line is longer that current window."
1732 (> (ti::line-length) (nth 2 (window-edges))))
1734 ;;; ----------------------------------------------------------------------
1736 (defun ti::re-search-check (re &optional level start-form read)
1737 "Check whole buffer for regexp RE.
1742 LEVEL which sublevel in regexp to match, default is 0
1743 START-FORM form yielding starting point of search. Default is `point-min'
1744 READ read the match instead of returning point
1748 start point of match at level.
1753 (goto-char (eval start-form))
1755 (when (re-search-forward re nil t)
1757 (match-string (or level 0))
1758 (match-beginning (or level 0))))))
1760 ;;; ----------------------------------------------------------------------
1762 (defun ti::re-search-point-list (regexp-list &optional pos-function end)
1763 "Return list of points that were found using REGEXP-LIST.
1765 REGEXP-LIST List of regexps
1766 POS-FUNCTION is used to position the point if regexp was found.
1767 The point used is read after POS-FUNCTION.
1768 END max search point."
1770 (dolist (re regexp-list)
1772 (when (re-search-forward re end t)
1773 (if pos-function (funcall pos-function))
1774 (push (point) list))))
1779 ;;{{{ Special lists, assoc
1781 ;;; ----------------------------------------------------------------------
1782 ;;; Many times you want to have data structure with some KEY
1784 (defmacro ti::assoc-append-inside (func key list add)
1785 "Add to the ASSOC list new ELT.
1786 List must be in format, K = key, E = element.
1787 ( (K . (E E) (K . (E E)) .. )
1791 FUNC 'assq or 'assoc or any other to get inner list
1798 (setq list '( (1 . (a b)) (2 . (c d))))
1799 (ti::assoc-append-inside 'assq 1 list 'x)
1802 '( (1 . (a b x)) (2 . (c d))))"
1806 (if (not (setq EL-T (funcall (, func) (, key) (, list))))
1807 (push (cons (, key) (list (, add))) (, list))
1808 (setq LIS-T (cdr EL-T))
1809 (push (, add) LIS-T)
1810 (setcdr EL-T LIS-T)))))
1812 ;;; ----------------------------------------------------------------------
1814 (defun ti::assoc-replace-maybe-add (target-list-sym list &optional remove)
1815 "Set TARGET-LIST-SYM entry to LIST of pairs (STRING . CDR-ELT).
1816 If the LIST's STRING is found, replace CDR-ELT of TARGET-LIST-SYM.
1817 If no STRING found, add new one to the beginning of TARGET-LIST-SYM.
1821 TARGET-LIST-SYM Is assoc list, e.g.
1822 `auto-mode-alist' or `interpreter-mode-alist'
1823 LIST Is assoc list that are used in replacing or adding.
1824 Similar to target-list-sym: ((STRING . SYM) ...)
1825 REMOVE Instead of adding or modifying, remove items.
1829 ;; This will redefine .el and .h definitions
1830 ;; in `auto-mode-alist'
1832 (ti::assoc-replace-maybe-add
1834 '((\"\\.el\\'\" . lisp-mode)
1835 (\"\\.h\\'\" . c++-mode)))
1845 ;; 1. We try to find the regexp. This may change from emacs to emacs
1846 ;; 2. If it is found (same as in previous emacs release), then change
1848 ;; 3. Prepend new member to the list to be sure that we get the
1849 ;; control over file name specification. If function is later called
1850 ;; again (reloading emacs settings), then control goes to case (2)
1851 ;; and we won't be prepending more cells to the list.
1853 (unless (ti::listp (car list))
1854 (error "Need LIST '( (STRING . SYM) )"))
1858 (dolist (elt (symbol-value target-list-sym))
1859 (setq regexp (car elt))
1860 (unless (assoc regexp list)
1864 (set target-list-sym (copy-alist copy))))
1868 ;; The ELT is cons: (REGEXP . CDR-ELT)
1869 (setq regexp (car elt) cdr-elt (cdr elt))
1870 ;; Is the regexp there already (the assoc makes the lookup)
1872 ((setq elt (assoc regexp (symbol-value target-list-sym)))
1873 (setcdr elt cdr-elt))
1875 (set target-list-sym
1877 (cons regexp cdr-elt)
1878 (symbol-value target-list-sym))))))))
1884 ;;; ----------------------------------------------------------------------
1886 (put 'ti::let-transform-nil 'edebug-form-spec '(body))
1887 (put 'ti::let-transform-nil 'lisp-indent-function 1)
1888 (defmacro* ti::let-transform-nil ((&rest vars) &body body)
1889 "Wrap list of VARS inside `let' and set all value to nil.
1890 This macro could be used to set e.g. hook values to temporarily
1893 (defvar my-hook-list '(find-file-hooks write-fil-hooks))
1896 (ti::let-transform-nil my-hook-list
1897 ... do something, the hooks are now suppressed.
1900 That is efectively save as you would have written:
1903 (let (find-file-hooks
1905 ... do something, the hooks are now suppressed.
1907 ;; If VARS is a variable, assume we wanted its value.
1908 ;; otherwise, we just take it as a literal list.
1909 ;; This means that both (ti::let-transform-nil (a b) ...)
1910 ;; and (ti::let-transform-nil foo ...) work (assuming foo is boundp).
1912 ;; This would also work:
1914 ;; (defmacro my-let (symbols &rest body)
1915 ;; `(progv ,symbols ,(make-list (length symbols) nil)
1919 (setq vars (symbol-value vars)))
1923 ;;; ----------------------------------------------------------------------
1925 (defsubst ti::list-make (single-or-list)
1926 "Converts SINGLE-OR-LIST into list.
1927 If argument is already a list this macro is no-op."
1928 (if (listp single-or-list)
1930 (list single-or-list)))
1932 ;;; ----------------------------------------------------------------------
1933 ;;; - unfortunately recursion is quite slow, but this is
1934 ;;; exceptional example!
1936 ;;; (defun list-flatten (l)
1937 ;;; (cond ((consp l) (append (flatten (car l)) (flatten (cdr l))))
1941 (defun ti::list-flatten (l)
1947 (setq stack (cons (cdr l) stack) l (car l))
1948 (setq result (cons l result) l nil))
1950 stack (cdr stack))))
1953 ;;; ----------------------------------------------------------------------
1954 ;;; #todo : should this use prin1-to-string, before extarcting elements,
1957 (defun ti::list-join (list &optional join-str)
1958 "Joins string LIST with JOIN-STR, whic defaults to space."
1960 (ch (or join-str " ")))
1962 (setq ret (concat (or ret "") (car list)))
1963 (setq list (cdr list))
1964 (if list ;only if still elements
1965 (setq ret (concat ret ch))))
1968 ;;; ----------------------------------------------------------------------
1970 (defun ti::list-to-assoc-menu (list)
1971 "Converts string or number items in LIST into assoc menu.
1972 Items are numbered starting from 0.
1974 '(1 2 \"a\" \"b\") --> '((\"1\" . 1) (\"2\" . 2) (\"a\" . 3) (\"b\" . 4))
1976 This is useful, if you call x popup menu or completion. For example:
1978 (completing-read \"complete number: \"
1979 (ti::list-to-assoc-menu '(111 222 333 444)))"
1984 (setq elt (int-to-string elt)))
1985 (push (cons elt i) ret)
1989 ;;; ----------------------------------------------------------------------
1991 (defsubst ti::list-to-cons (list)
1992 "Turn list to paired cons list '(1 2 3 4) --> '((1 . 2) (3 .4))."
1995 (push (cons (pop list) (pop list)) ret))
1998 ;;; ----------------------------------------------------------------------
2000 (defun ti::list-remove-successive (list function)
2001 "Remove succesive same elements from LIST.
2006 FUNCTION accept Arg1 and Arg2 in list, should return non-nil
2007 if elements are the same. Arg1 and Arg2 are taken
2008 as 'car' in the list.
2012 (ti::list-remove-successive '(1 1 2 2 3) 'eq)
2014 (ti::list-remove-successive '(\"1\" \"1\" \"2\" \"2\" \"3\") 'string=)
2015 --> '(\"1\" \"2\" \"3\")"
2019 (unless (funcall function prev elt)
2020 (setq prev elt) ;prev value
2021 (push elt new-list)))
2022 (nreverse new-list)))
2027 ;;; ----------------------------------------------------------------------
2028 ;;; This is very useful when contruction interactive calls
2030 ;;; (ti::list-merge-elements
2031 ;;; (region-beginning)
2033 ;;; (funcall get-3-arg-list) ;; this returns '(arg1 arg2 arg3)
2036 ;;; --> (1 100 arg1 arg2 arg3)
2038 (defun ti::list-merge-elements (&rest args)
2039 "Merge single elements, ARGS, and one dimensional lists to one list.
2041 (ti::list-merge-elements 1 2 'some '(type here))
2043 '(1 2 some type here)"
2047 (dolist (x elt) (push x ret))
2051 ;;; ----------------------------------------------------------------------
2052 ;;; - Ever struggled with peeking the lists..?
2053 ;;; - I have, and printing the contents of auto-mode-alist into
2054 ;;; the buffer is very easy with this.
2055 ;;; - Should be default emacs function.
2057 (defun ti::list-print (list)
2058 "Insert content of LIST into current point."
2059 (interactive "XLisp symbol, list name: ")
2062 (lambda (x) (insert (ti::string-value x) "\n")))
2065 ;;; ----------------------------------------------------------------------
2067 (defsubst ti::list-to-string (list &optional separator)
2068 "Convert LIST into string. Optional SEPARATOR defaults to \" \".
2072 LIST '(\"str\" \"str\" ...)
2078 (function identity) ;returns "as is"
2080 (or separator " ")))
2082 ;;; ----------------------------------------------------------------------
2083 ;;; This enables you to access previous and next element easily.
2085 (defun ti::list-elt-position (list arg &optional test-form)
2086 "Return position 0..x in list.
2091 ARG this position in list is sought
2092 TEST-FORM defaults to 'equal, you can use ARG and LIST in the
2093 test form. Example: '(string= (car list) arg)
2096 nil ,no ARG in list"
2102 (equal (car list) arg))
2103 (setq ret i list nil)
2105 (setq list (cdr list))))
2108 ;;; ----------------------------------------------------------------------
2110 (defun ti::list-find (table arg &optional test-function all-matches)
2111 "Loops through TABLE until element matching ARG is found.
2115 TEST-FUNCTION defaults to (string-match (caar element) arg)
2116 and the supposed list is assumed to be:
2117 '( (\"REGEXP\" ANY_DATA) ..)
2119 ALL-MATCHES flag, if non-nil return list of matches.
2121 You can refer to these items in the test-form
2123 arg Argument as passed.
2124 element current item beeing compared, also the actual element
2125 stored to list if match return t. Defaults to (car table)
2129 (defconst my-list '((\"1\" \"a\") (\"2\" \"b\")))
2131 ;; This is like using 'assoc'
2133 (ti::list-find my-list \"1\")
2136 ;; Do match against member 2
2138 (ti::list-find my-list \"b\" '(string-match (nth 1 element) arg))
2141 ;; This is little tricky, we search all '.fi' sites, and then
2142 ;; remove all whitespaces around the items.
2144 (defconst my-list2 '(\" foo@a.fi \" \"Bar <man@b.fi> \" \"gee@c.uk \"))
2146 (ti::list-find my-list2 \"[.]fi\"
2148 (string-match arg element)
2149 (setq element (ti::string-remove-whitespace element)))
2152 --> (\"foo@a.fi\" \"Bar <man@b.fi>\")
2157 element single element
2158 list list is returned if all-items is non-nil"
2160 (dolist (element table)
2161 (when (if test-function
2162 (funcall test-function arg element)
2163 (string-match (car element) arg))
2164 (if all-matches ;how to put results ?
2165 (ti::nconc ret element)
2171 ;;{{{ misc, window, frame, events, popup
2173 ;;; ----------------------------------------------------------------------
2175 (defsubst ti::non-dedicated-frame (&optional win)
2176 "Return some non-dedicated frame. The current frame is looked from WIN."
2177 (if (window-dedicated-p (selected-window))
2178 (car (ti::window-frame-list nil nil win))
2180 (window-frame (get-buffer-window (current-buffer)))))
2182 ;;; ----------------------------------------------------------------------
2184 (defsubst ti::select-frame-non-dedicated ()
2185 "Move to some non dedicated frame if current frame (window) is dedicated.
2186 E.g. you can't call `find-file', `switch-to-buffer' in dedicated frame."
2187 (if (window-dedicated-p (selected-window))
2188 (raise-frame (select-frame (car (ti::window-frame-list))))))
2190 ;;; ----------------------------------------------------------------------
2192 (defmacro ti::byte-compile-defun-compiled-p (function-symbol)
2193 "Check if FUNCTION-SYMBOL is byte compiled."
2194 ;; byte-code-function-p is marked obsolete in 19.14
2195 ;; compiled-function-p is an obsolete in 19.34
2197 (` (byte-code-function-p (symbol-function (, function-symbol))))
2198 (` (compiled-function-p (symbol-function (, function-symbol))))))
2200 ;;; ----------------------------------------------------------------------
2202 (defmacro ti::byte-compile-defun-maybe (defun-list)
2203 "Byte compile `DEFUN-LIST only if not currently byte compiling.
2204 If you have highly important functions that must be as fast as possible
2205 no matter how the package is loaded you would do this:
2207 (defun function1 () ...)
2208 (defun function2 () ...)
2210 ;; At the end of file
2211 (ti::byte-compile-defun-maybe '(function1 function2))
2213 Now if package is loaded in .el format, this will trigger byte compiling
2214 those functions. If the package is currently beeing byte compiled, then
2215 the code does nothing. Note: loading package always causes byte compiling
2216 the functions although they may already be byte compiled. This will not
2220 ;; If not package compiltion in progress....
2222 (unless (byte-compiling-files-p)
2223 (dolist (function (, defun-list))
2224 (byte-compile function) )))))
2226 ;;; ----------------------------------------------------------------------
2228 (defmacro ti::package-use-dynamic-compilation ()
2229 "Turn on dynamic compilation in current buffer.
2230 Add this statement to the beginning of file:
2232 (eval-when-compile (ti::package-use-dynamic-compilation))"
2235 (when (boundp 'byte-compile-dynamic)
2236 (make-local-variable 'byte-compile-dynamic)
2237 (defvar byte-compile-dynamic) ;; silence byte compiler
2238 (set 'byte-compile-dynamic t))
2239 (when (boundp 'byte-compile-dynamic-docstring)
2240 ;; In 19.34 this is t by default
2241 (make-local-variable 'byte-compile-dynamic-docstring)
2242 (defvar byte-compile-dynamic-docstring) ;; silence byte compiler
2243 (set 'byte-compile-dynamic-docstring t)))))
2245 ;;; ----------------------------------------------------------------------
2247 (defun ti::function-autoload-file (function)
2248 "Return filename where autoload FUNCTION refers to"
2249 (let* ((str (prin1-to-string (symbol-function function))))
2251 (string-match "autoload[ \t\\]+\"\\([^\\\"]+\\)" str))
2252 (match-string 1 str))))
2254 ;;; ----------------------------------------------------------------------
2256 (defmacro ti::package-require-for-emacs (emacs xemacs &rest body)
2257 "EMACS and XEMACS package compatibility. Evaluate BODY.
2258 E.g. `timer' in Emacs and 'itimer in XEmacs
2259 Recommended usage: (eval-and-compile (ti::package-require-for-emacs ...))."
2263 (unless (featurep (, emacs))
2266 (unless (featurep (, xemacs))
2267 (require (, xemacs))
2270 ;;; ----------------------------------------------------------------------
2272 (defmacro ti::package-require-view ()
2273 "Emacs and XEmacs compatibility. Load view package."
2275 (if (ti::xemacs-p "20")
2276 (require 'view-less)
2279 ;;; ----------------------------------------------------------------------
2281 (defmacro ti::package-package-require-timer ()
2282 "Emacs and XEmacs compatibility. Load view package."
2288 ;;; ----------------------------------------------------------------------
2290 (defmacro ti::package-require-mail-abbrevs ()
2291 "Emacs and XEmacs compatibility. Load mail abbrevs package.
2292 Recommended usage: (eval-and-compile (use-mail-abbrevs))"
2294 (ti::package-require-for-emacs
2297 (when (fboundp 'mail-abbrevs-setup) ;; Emacs
2298 (ti::funcall 'mail-abbrevs-setup)))))
2300 ;;; ----------------------------------------------------------------------
2302 (defmacro ti::use-file-compression ()
2303 "Activate jka-compr.el."
2305 ((or (featurep 'jka-compr)
2306 (featurep 'crypt++))) ;That's ok then.
2307 ((and (featurep 'vm)
2308 (require 'crypt++ nil 'noerr)))
2311 ** Tinylibm: VM and compression was requested but no 'crypt++ feature provided.
2312 ** Tinylibm: Visit ftp://ftp.cs.umb.edu/pub/misc/.
2313 ** Tinylibm: Cannot deduce to jka-compr,
2314 ** Tinylibm: because it has been previously reported that VM is not
2315 ** Tinylibm: compatible with jka-compr. (1999-02 up till Emacs 20.3"))
2317 (require 'jka-compr)
2318 (if (fboundp 'jka-compr-install)
2319 (jka-compr-install)))))) ;New Emacs and XEmacs releases need this
2321 ;;; ----------------------------------------------------------------------
2322 ;;; #todo: what to do with .zip or other files?
2324 (defun ti::use-file-compression-maybe (file)
2325 "Activate file compression if FILE name contains magic .gz .Z etc."
2326 (when (stringp file)
2328 ((string-match "\\.gz$\\|\\.[Zz]$\\|\\.bz2$" file)
2329 (if (fboundp 'auto-compression-mode) ;; New Emacs: jka-compr.el
2330 (ti::funcall 'auto-compression-mode 1)
2331 (ti::use-file-compression))))))
2336 ;;; ----------------------------------------------------------------------
2338 (defun ti::push-definition (symbol &optional func-flag)
2339 "Push current definition of SYMBOL to stack.
2340 If FUNC-FLAG is non-nil, then push function definition.
2342 Stack is at kept in property 'definition-stack"
2344 (push (symbol-function symbol) (get symbol 'definition-stack))
2345 (push (symbol-value symbol) (get symbol 'definition-stack))))
2347 ;;; ----------------------------------------------------------------------
2349 (defun ti::pop-definition (symbol &optional func-flag)
2350 "Retrieve previous definition of SYMBOL from stack.
2351 If FUNC-FLAG is non-nil, then pop function definition.
2353 Stack is at kept in property 'definition-stack"
2355 (setf (symbol-function symbol) (pop (get symbol 'definition-stack)))
2356 (setf (symbol-value symbol) (pop (get symbol 'definition-stack)))))
2358 ;;; ----------------------------------------------------------------------
2360 (defsubst ti::use-prefix-key (map key)
2361 "Define to MAP a prefix KEY. If KEY is not keymap, allocate the key.
2362 Return KEY's original binding."
2363 (if (not (keymapp (lookup-key map key)))
2364 (prog1 ;Make it available
2365 (lookup-key map key)
2366 (define-key map key nil))))
2368 ;;; ----------------------------------------------------------------------
2369 ;;; I use this to change the BIG letter maps to `low' letter maps
2371 (defun ti::swap-keys-if-not-keymap (sym old-key new-key)
2372 "In keymap SYM, swap OLD-KEY and NEW-KEY only _if_ NEW-KEY is not a keymap.
2376 Suppose you have Gnus map 'A' and you don't like to type
2377 uppercase letters. You want to change the keymap 'A' to 'a'. Here is
2378 the command. Notice that this executes only once, because after the
2379 function is called the \"a\" NEW-KEY is the keymap of 'A' now. You
2380 can safely use this function within hooks for that reason.
2382 (ti::swap-keys-if-not-keymap \"A\" \"a\")"
2383 (when (ti::emacs-p) ;; Keymaps in XEmacs are not lists
2384 (let* ((keymap (symbol-value sym))
2385 (new-cdr (lookup-key keymap new-key)) ;; may be function too
2386 (old-cdr (lookup-key keymap old-key)))
2387 (when nil ;; disabled
2389 new-key new-cdr (fboundp new-cdr)
2395 (when (or (not (keymapp new-cdr)) ;Already moved
2399 (not (keymapp (symbol-function new-cdr)))))
2401 (define-key keymap new-key old-cdr)
2402 (define-key keymap old-key new-cdr)
2403 (set sym (copy-keymap keymap))))))
2405 ;;; ----------------------------------------------------------------------
2407 (defmacro ti::define-buffer-local-keymap ()
2408 "Copy current local keymap and execute `use-local-map'.
2409 After that your commands with `local-set-key' are buffer local."
2411 (copy-keymap (or (current-local-map) (make-sparse-keymap)))))
2413 ;;; ----------------------------------------------------------------------
2415 (defmacro ti::define-key-if-free (map key object &optional callback)
2416 "Put key to map if key is not assigned already.
2418 Key can be assigned if
2421 o slot has function 'ignore
2422 o slot has already object
2424 Any other case generates error: the slot is already occupied.
2426 You normally call this function from package that want's to define
2427 e.g. function keys permanently and if there is already user definition
2428 you can stop right there and print message.
2432 MAP map where to define the key e.g. `global-map'
2434 OBJECT assin object to key.
2435 CALLBACK on error call function CALLBACK with argument KEY and the
2436 result of `lookup-key'.
2440 (ti::define-key-if-free global-map [f10]
2441 'xxx-func 'xxx-define-key-error)
2443 (defun xxx-define-key-error (key def)
2445 (format \"package xxx: key %s is already occupied with %s\"
2446 \"Please use manual customization.\"
2449 (let ((def (lookup-key (, map) (, key) )))
2450 ;; Lookup key returns NBR if the sequence of keys exceed
2451 ;; the last keymap prefix
2452 ;; C-cck --> C-cc is undefined, so there is no C-c c map yet
2454 (if (or (eq def (, object))
2455 (memq def '(nil ignore))
2457 (define-key (, map) (, key ) (, object))
2459 (funcall (, callback) (, key ) def)
2461 (format "Already occupied, key: %s slot content: %s "
2463 (prin1-to-string def))))))))
2465 ;;; ----------------------------------------------------------------------
2467 (defun ti::define-in-function-keymap (list)
2468 "Move key definition according to LIST '((FROM TO) (FROM TO) ..)
2469 This function remap each key FROM to produce TO key instead.
2473 You're in terminal where tab key produces `kp-tab' and not the normal `tab'.
2474 You verified this by looking at the \\[view-lossage]. You want that key
2475 to give key code `tab' to Emacs:
2477 (ti::define-in-function-keymap
2479 ([C-kp-tab] [C-tab])
2480 ([S-kp-tab] [S-tab])
2481 ([A-kp-tab] [A-tab])
2482 ([C-S-kp-tab] [C-S-tab])))
2484 Note: The global binging of FROM key is set to nil in order to remap
2485 to take effect. Do not define FROM key globally after this."
2487 (when (and (car elt) (nth 1 elt))
2488 (define-key function-key-map (car elt) (nth 1 elt)) ;; Alt
2489 (define-key global-map (car elt) nil))))
2491 ;;; ----------------------------------------------------------------------
2493 (defmacro ti::copy-key-definition (map to-key from-key)
2494 "Put to MAP a TO-KEY that is bound to FROM-KEY.
2495 You can use this function e.g. in minor modes, where when minor
2496 mode is turned on, it moves some key definitions to somewhere
2497 else. For example if minor mode wants to take over PgUp and PgDown
2498 keys, but preserve their original menaing under some other key,
2499 it could copy the function calls to sme other key like
2500 control-PgUp and control-PgDown.
2504 ;; move PgUp/Down under Control key. Preserve their original
2505 ;; function that may not be simple scroll-down!
2507 (copy-key-function map [C-prior] [prior])
2508 (copy-key-function [C-next] [prior])
2510 ;; Now occupy minor map definition
2512 (define-key [prior] 'minor-mode-function)"
2514 (define-key (, map) (, to-key)
2515 (or (and (current-local-map)
2516 (lookup-key (current-local-map) (, from-key)))
2517 (lookup-key global-map (, from-key)) ))))
2519 ;;; ----------------------------------------------------------------------
2521 (defsubst ti::beginning-of-defun-point (&optional end)
2522 "Search function beginning or END. Point is preserved. No errors.
2530 (beginning-of-defun))
2533 ;;; ----------------------------------------------------------------------
2535 (defsubst ti::digit-length (arg)
2536 "Return number of digits in ARG which must be either number or string.
2537 If ARG is string, the length of string is returned."
2540 (setq val (int-to-string arg)))
2543 ;;; ----------------------------------------------------------------------
2545 (defun ti::add-hook-fix ()
2546 "Arrange some write file hooks to correct order. Support crypt++.el"
2547 (let* ((crypt-w (memq 'crypt-write-file-hook write-file-hooks)))
2549 (when crypt-w ;; Crypt present
2550 (let* ((crypt-f (memq 'crypt-find-file-hook find-file-hooks))
2551 (crypt-n (memq 'find-file-not-found-hooks
2552 find-file-not-found-hooks )))
2553 (when (not (null (cdr crypt-w))) ;; Not in the end of the hook
2554 (remove-hook 'crypt-write-file-hook 'write-file-hooks)
2555 (add-hook 'crypt-write-file-hook 'write-file-hooks 'append))
2557 (when (not (null (cdr (reverse crypt-f)))) ;; Not at the beginning
2558 (remove-hook 'crypt-find-file-hook 'find-file-hooks)
2559 (add-hook 'crypt-find-file-hook 'find-file-hooks 'append))
2561 (when (not (null (cdr (reverse crypt-n)))) ;; Not at the beginning
2562 (remove-hook 'find-file-not-found-hooks 'find-file-hooks)
2563 (add-hook 'find-file-not-found-hooks 'find-file-hooks 'append))))))
2565 ;;; ----------------------------------------------------------------------
2566 ;;; - add-hook should accept many parameters...
2568 (defun ti::add-hooks
2569 (hook-or-list single-or-list &optional remove append check)
2570 "Run `add-hook' to insert every element in HOOK-OR-LIST to SINGLE-OR-LIST.
2574 Thic function calls `ti::add-hook-fix` if the hook in question
2575 is `write-file-hooks' (Crypt support)
2579 `add-hook' call creates a hook variable if it doesn't exist.
2583 HOOK-OR-LIST hook symbol, or list of hook symbols
2584 LIST single function or list of functions
2585 REMOVE flag, if non-nil run `remove-hook' instead.
2586 APPEND parameter to `add-hook'
2587 CHECK run ´boundp' check before trying to add to a hook.
2588 Only if variable exists, run `add-hook' or `remove-hook'
2592 ;; Add 2 functions to 2 hooks
2594 (ti::add-hooks '(mode1-hook mode2-hook) '(hook1 hook2))"
2595 (let* ((list (ti::list-make single-or-list))
2596 (hlist (ti::list-make hook-or-list)))
2597 (dolist (hook hlist)
2598 (if (eq hook 'write-file-hooks)
2599 ;; Arrange some write file hooks to correct order (crypt.el)
2602 (when (or (null check)
2606 (remove-hook hook x)
2607 (add-hook hook x append)))))))
2609 ;;; ----------------------------------------------------------------------
2611 (defun-maybe subst-char-with-string (string &optional char to-string)
2612 "In STRING, converts CHAR with TO-STRING.
2613 Default is to convert all tabs in STRING with spaces."
2614 (let* ((len (length string))
2619 ((not (and char to-string))
2622 (untabify (point-min) (point-max))
2623 (setq ret (buffer-string))))
2626 (setq elt (char-to-string (aref string i)))
2627 (if (char= char (aref string i))
2628 (setq elt to-string))
2629 (setq ret (concat ret elt))
2633 ;;; ----------------------------------------------------------------------
2635 (defun ti::prefix-arg-to-text (arg)
2636 "Return a string describing the current prefix argument ARG."
2639 ((integerp arg) (int-to-string arg))
2640 ((eq '- arg) "C-u - ")
2641 ((integerp arg) (format "C-u %d " current-prefix-arg))
2643 (apply 'concat (make-list (round (log (car arg) 4)) "C-u ")))))
2645 ;;; ----------------------------------------------------------------------
2647 (defmacro ti::keep-lower-order (var1 var2)
2649 (` (let ((MiN (min (, var1) (, var2)))
2650 (MaX (max (, var1) (, var2))))
2652 (setq (, var2) MaX))))
2654 ;;; ----------------------------------------------------------------------
2656 (defmacro ti::bool-toggle (var &optional arg)
2657 "Toggle VAR according to ARG like mode would do.
2658 Usefull for for functions that use arg 0/-1 = off, 1 = on, nil = toggle.
2659 Minor modes behave this way.
2661 VAR is set to following values when ARG is:
2664 arg nil VAR -> not(var) toggles variable"
2666 ;; The `let' is mandatory. XEmacs byte compiler will not allow
2667 ;; expanding the variable in numeric context. If we used
2669 ;; (and (integerp (, arg))
2672 ;; That would compile into this (when optional ARG is nil)
2674 ;; (and (integerp nil)
2675 ;; (< nil 1)) ;; <= Byte compiler error
2677 ;; The message from XEmacs 21.5 would say:
2678 ;; ** evaluating (< nil 1): (wrong-type-argument number-char-or-marker-p nil)
2680 (let ((toggle (, arg)))
2683 ((and (integerp toggle)
2684 (< toggle 1)) ;Any negative value or 0
2686 ((integerp toggle) ;Any positive value
2697 ;;{{{ buffers, variables
2699 ;;; ----------------------------------------------------------------------
2701 (defmacro ti::compat-load-user-init-file ()
2702 "Emacs and XEmacs compatibility."
2704 ((boundp 'load-user-init-file-p)
2705 (intern "load-user-init-file-p"))
2706 ((boundp 'init-file-user)
2707 (intern "init-file-user"))
2709 (error "Unknown Emacs."))))
2711 ;;; ----------------------------------------------------------------------
2713 (defsubst ti::compat-Info-directory-list-symbol ()
2714 "Emacs and XEmacs compatibility. Return symbol."
2716 ((boundp 'Info-directory-list) ;; XEmacs
2717 (intern "Info-directory-list"))
2718 ((boundp 'Info-default-directory-list)
2719 (intern "Info-default-directory-list"))))
2721 ;;; ----------------------------------------------------------------------
2723 (defsubst ti::compat-Info-directory-list ()
2724 "Emacs and XEmacs compatibility. Return value."
2725 (symbol-value (ti::compat-Info-directory-list-symbol)))
2727 ;;; ----------------------------------------------------------------------
2729 (defun ti::buffer-pointer-of-info ()
2730 "Return Emacs or XEmacs *info* buffer."
2731 ;; This buffer should have been defvar'd in Emacs
2732 (get-buffer "*info*"))
2734 ;;; ----------------------------------------------------------------------
2736 (defun ti::buffer-pointer-of-messages ()
2737 "Return Emacs or XEmacs MESSAGE buffer."
2738 ;; The buffer name should be in variable and not hard coded
2739 ;; Bad desing from Emacs folks...
2741 ;; The following is not used, because it's not strictly accurate:
2743 ;; (or (get-buffer "*Messages*")
2744 ;; (get-buffer " *Message-Log*"))
2746 ;; An emacs type is tested because the buffer name is exactly that
2749 (get-buffer "*Messages*")
2750 (get-buffer " *Message-Log*")))
2752 ;;; ----------------------------------------------------------------------
2754 (defun ti::last-message-line ()
2755 "Return last line from message buffer."
2756 (let* ((buffer (ti::buffer-pointer-of-messages)))
2758 (with-current-buffer buffer
2760 (re-search-backward "[^\t\n ]" nil t)
2761 (ti::read-current-line)))))
2763 ;;; ----------------------------------------------------------------------
2765 (defmacro ti::dolist-buffer-list
2766 (test-form &optional temp-buf exclude-form &rest action-form)
2767 "Return list of buffer names matching TEST-FORM.
2769 If optional TEMP-BUF is non-nil, every buffer is searched.
2770 Normally following buffers are ignored.
2771 - Temporary buffers which start with character asterisk '*'
2772 - Invisible buffers which start with space ' '
2774 Optional EXCLUDE can also be given, which excludes buffers from
2777 If optional ACTION-FORM is given executes forms for every matched buffer.
2778 At the moment of eval the `set-buffer' is already done.
2782 TEST-FORM regexp or form to get matching buffers.
2783 TEMP-BUF flag. Non-nil allows scanning temp buffers too
2784 EXCLUDE-FORM regexp or form -- against matched ones
2785 ACTION-FORM if exist, eval this for every buffer.
2787 Internal variables that you can refer to:
2789 buffer the current buffer pointer
2793 list (buffer-name buffer-name ..)
2797 ;; Get all buffers matching \"cc\"
2798 (ti::dolist-buffer-list \"cc\")
2800 ;; Get all buffers in `dired-mode'
2801 (ti::dolist-buffer-list '(eq major-mode 'dired-mode))
2807 (dolist (buffer (buffer-list))
2808 (setq BN (buffer-name buffer))
2809 (when (stringp BN) ;it's killed if no name
2810 (with-current-buffer buffer
2813 (when (, exclude-form)
2816 (if (and (null (, temp-buf))
2817 (string-match "^[* ]" BN))
2819 (push BN return-list)
2820 (,@ action-form)))))))
2823 ;;; ----------------------------------------------------------------------
2824 ;;; Emacs erase-buffer doesn't take arguments
2826 (defun ti::erase-buffer (&optional buffers)
2827 "Clear list of BUFFERS. Buffer existense is not checked."
2828 (setq buffers (or (ti::list-make buffers)
2829 (list (current-buffer))))
2830 (save-current-buffer
2831 (dolist (elt buffers)
2835 ;;; ----------------------------------------------------------------------
2836 ;;; - The buffer is *not* cleared by default, only put to consistent state
2838 (defun ti::temp-buffer (&optional buffer clear)
2839 "Create and reset temporary BUFFER.
2840 Remove read-only. Buffer name is \"*tmp*\" by default.
2841 Put buffer to `fundamental-mode' and remove any narrowing and `font-lock-mode'.
2842 if CLEAR is non-nil, delete old buffer content.
2847 (let (font-lock-mode ;Handles defer-lock and fast-lock too
2849 global-font-lock-mode)
2850 ;; Old Emacs doesn't have these, ByteComp silencer
2851 ;; This buffer doesn't need to know about font-lock.
2852 (if font-lock-mode (setq font-lock-mode nil))
2853 (if lazy-lock-mode (setq lazy-lock-mode nil))
2854 (if global-font-lock-mode (setq global-font-lock-mode nil))
2855 (get-buffer-create (or buffer "*tmp*"))))
2856 (sym 'font-lock-mode)
2857 (sym-lazy 'lazy-lock-mode))
2859 (with-current-buffer buffer
2860 (unless (eq major-mode 'fundamental-mode)
2861 (fundamental-mode)) ;No fancy modes here
2863 (setq buffer-read-only nil)
2865 ;; Defconst used instead of setq due to old Emacs, where
2866 ;; these variables have not been defined.
2867 ;; `sym' just foold ByteCompiler again... (`set' would whine otw)
2869 (if (boundp sym) ;Exist; okay then ...
2870 (set sym nil)) ;Keep documentation
2872 (if (boundp sym-lazy)
2875 ;; - This call has been commented for now, because it prints
2876 ;; unecessary message every time it's beeing called.
2877 ;; - Besides the modified flag is not much used for "star",tmp, buffers
2879 ;; (set-buffer-modified-p nil)
2881 ;; - We don't check the possible narrowing. Just go and widen
2888 ;;; ----------------------------------------------------------------------
2890 (defsubst ti::append-to-buffer (buffer string &optional beg-flag)
2891 "Append to BUFFER a STRING. If BEG-FLAG is non-nil, prepend to buffer."
2892 (with-current-buffer buffer
2898 ;;; ----------------------------------------------------------------------
2900 (defun ti::set-buffer-safe (buffer)
2901 "Execute `set-buffer' if BUFFER exists. Does not signal any error.
2903 buffer pointer if `set-buffer' executed
2904 nil buffer does not exist"
2905 (if (buffer-live-p (get-buffer buffer))
2906 (set-buffer buffer)))
2908 ;;; ----------------------------------------------------------------------
2910 (defun ti::kill-buffer-safe (buffer)
2911 "Do `kill-buffer' only if BUFFER exists. Does not signal any error.
2912 The buffer is killed, even if modified.
2916 (save-current-buffer
2917 (when (ti::set-buffer-safe buffer)
2918 (set-buffer-modified-p nil) ;No confirmation when we kill it
2919 (kill-buffer buffer))))
2924 ;;; #todo: rename to `obarray' functions or get rid of these and use cl hash
2926 ;;; These are normally calld hash tables, or Emacs says they are obarrays.
2929 ;;; The idea is to store uniq ITEMS into vectors, like filenames.
2930 ;;; Then each filename can have properties, like rcs version number,
2931 ;;; locker, date of creation etc.
2933 ;;; ----------------------------------------------------------------------
2934 ;;; - just setting the hash to nil; does not kil the contents of hash.
2935 ;;; For top security like passwords; each element must be zeroed.
2937 (defun-maybe cl-clrhash-paranoid (hash)
2938 "Clear HASH by filling every item and then calling `cl-clrhash'.
2939 This should clear memory location contents."
2942 (fillarray v ?\0)) ;; propably faster
2943 ;;; (loop for i from 0 to (1- (length v))
2944 ;;; do (aset v i ?\0))
2948 ;;; ----------------------------------------------------------------------
2949 ;;; File: elisp, Node: Creating Symbols
2950 ;;; - In Emacs Lisp, an obarray is actually a vector
2951 ;;; - In an empty obarray, every element is 0
2952 ;;; - lengths one less than a power of two
2954 (defmacro ti::vector-table-init (table &optional size init-val)
2955 "Clears vector TABLE. Default SIZE is 128 buckets. INIT-VAL defaults to 0."
2956 (` (setq (, table) (make-vector (or (, size) 127) (or (, init-val) 0)))))
2958 ;;; ----------------------------------------------------------------------
2960 (defmacro ti::vector-table-get (table item &optional allocate)
2961 "Read vector TABLE and return ITEM. ALLOCATE if ITEM does not exist."
2963 (intern (, item) (, table))
2964 (intern-soft (, item) (, table)))))
2966 ;;; ----------------------------------------------------------------------
2968 (defun ti::vector-table-property (table item prop &optional put-value force-set)
2969 "In vector TABLE and ITEM, get or put property PROP.
2974 ITEM If ITEM is not allocated bucket, signal error.
2975 PROP property symbol
2976 PUT-VALUE value to put. If this is non-nil value is stored.
2977 FORCE-SET flag, if non-nil then put anything that was in put-value
2978 E.g. value nil can be stored this way."
2980 (if (null (setq sym (ti::vector-table-get table item)))
2981 (error "No bucket found for item. [item not in table] %s" item)
2982 (if (or put-value force-set)
2983 (put sym prop put-value)
2986 ;;; ----------------------------------------------------------------------
2988 (defmacro ti::vector-table-clear (table)
2989 "Delete all values assicated to interned symbols in TABLE.
2990 If possible, unintern all symbols."
2996 (when (fboundp 'unintern)
2997 (ti::funcall 'unintern atom (, table))))
2999 (unless (fboundp 'unintern) ;Old way
3000 (ti::vector-table-init (, table) (length (, table))))
3007 ;;; ----------------------------------------------------------------------
3009 (defun ti::expand-file-name-tilde-in-string (string)
3010 "Expand ~ referenced in string."
3011 ;; #todo: Not quite right, because XEmacs can be build under Win32/Cygwin
3012 ;; and ~user would be valid.
3013 (unless (ti::win32-p)
3014 (while (string-match "\\(~[^ \n\t\\/]+\\)" string)
3017 (expand-file-name (match-string 1 string))
3021 ;;; ----------------------------------------------------------------------
3023 (defsubst ti::file-name-path-p (file)
3024 "Check if file looks like a pathname, which includes slash or backslash."
3025 (string-match "[\\/]" file))
3027 ;;; ----------------------------------------------------------------------
3029 (defsubst ti::file-name-path-absolute-p (file)
3030 "Check if file looks like a absolute pathname."
3031 (or (string-match "^[a-z]:[\\/]" file) ;; win32
3032 (string-match "^[/~]" file))) ;; Unix
3034 ;;; ----------------------------------------------------------------------
3036 (defun ti::directory-move (from to)
3037 "Move directory FROM TO. Relies on `mv' command. Return command results."
3039 (let ((mv (or (executable-find "mv")
3040 (error "TinyLib: `mv' command not found."))))
3041 (call-process mv nil (current-buffer) nil
3042 (expand-file-name from)
3043 (expand-file-name to)))
3046 ;;; ----------------------------------------------------------------------
3048 (defun ti::write-file-with-wrapper (file)
3049 "Write file, possibly compressed. Crypt++ compatibility.
3050 Bind `crypt-auto-write-buffer' to t for Crypt++."
3051 (let* ((crypt-auto-write-buffer t)
3052 (buffer (find-buffer-visiting file))
3054 (unless crypt-auto-write-buffer ;Bytecomp silencer
3055 (setq crypt-auto-write-buffer nil))
3057 ;; In XEmacs, if there is buffer visiting with the same filename,
3058 ;; the user is prompted. Try to avoid it.
3059 ;; If there is buffer and it is not modified, kill it
3060 ;; and reload. Otherwise call normal write file.
3063 (with-current-buffer buffer
3064 (if (not (buffer-modified-p))
3066 (pop-to-buffer buffer)
3068 Tinylibm: Can't write to file. Modified buffer with the same name in Emacs."))))
3070 ;; I tried to RENAME buffer-name and set buffer-file-name to
3071 ;; something else, but XEmacs still thinks that the buffer
3072 ;; is saved with original name and asks from user permission.
3074 ;; There is nothing left to do but kill the buffer and reload it.
3075 ;; --> this unfortunately doesn't preserve markers.
3076 ;; I would have wanted to use `revert-buffer' instead.
3078 ;; If someone knows how to fool XEmacs to think buffer is
3079 ;; under some other name/file, let me know.
3082 (kill-buffer buffer))
3087 (find-file-noselect file))))
3089 ;;; ----------------------------------------------------------------------
3091 (put 'ti::load-file-with-wrapper 'lisp-indent-function 0)
3092 (defmacro ti::load-file-with-wrapper (file)
3093 "Load possibly compressed lisp file. Crypt++ support."
3095 (if (not (featurep 'crypt++))
3096 (load-file file) ;jka-compr handles this.
3097 (ti::file-eval file))))
3099 ;;; ----------------------------------------------------------------------
3101 (put 'ti::write-file-binary-macro 'lisp-indent-function 0)
3102 (defmacro ti::write-file-as-is-macro (&rest body)
3103 "Write file without any coding conversions."
3105 (let* ((buffer-file-coding-system 'no-conversion)) ;; #todo: XEmacs?
3108 ;;; ----------------------------------------------------------------------
3110 (defun ti::directory-list (dir)
3111 "Return all directories under DIR."
3113 (dolist (elt (directory-files dir 'full))
3114 (when (and (file-directory-p elt)
3115 (not (string-match "[\\/]\\.\\.?$" elt)))
3119 ;;; ----------------------------------------------------------------------
3121 (put 'ti::directory-recursive-macro 'lisp-indent-function 1)
3122 (put 'ti::directory-recursive-macro 'edebug-form-spec '(body))
3123 (defmacro ti::directory-recursive-macro (directory &rest body)
3124 "Start from DIRECTORY and run BODY recursively in each directories.
3126 Following variables are set during BODY:
3128 `dir' Directrory name
3129 `dir-list' All directories under `dir'."
3133 (let* ((dir-list (ti::directory-list dir)))
3136 (dolist (elt dir-list)
3138 (recurse (, directory)))))
3140 ;;; ----------------------------------------------------------------------
3142 (defsubst ti::file-name-remote-p (file)
3143 "Check if file looks like remote FILE. (ange-ftp)."
3144 (string-match "^[^ \t]+@[^ \t]+:" file))
3146 ;;; ----------------------------------------------------------------------
3147 ;;; (ti::file-name-backward-slashes "/cygdrive/f/test")
3148 ;;; (ti::file-name-backward-slashes "//f/test")
3149 ;;; (ti::file-name-backward-slashes "//f")
3151 (defun ti::file-name-backward-slashes (file)
3152 "Convert FILE to use baskward slashes, like dos format."
3154 (setq file (subst-char-in-string ?/ ?\\ file))
3156 ;; handle cygwin paths as well
3157 ;; //e/old-syntax B19 and B20
3158 ;; /cygdrive/e/new-syntax V1.1+
3160 (while (when (string-match
3161 "\\(\\([\\]cygdrive[\\]\\|[\\][\\]\\)\\([a-z]\\)\\)[\\]?.*"
3163 (setq file (replace-match (concat (match-string 3 file) ":")
3167 ;;; ----------------------------------------------------------------------
3169 (defsubst ti::file-name-forward-slashes (file)
3170 "Convert FILE slashes to unix format."
3172 (subst-char-in-string ?\\ ?/ file)))
3174 ;;; ----------------------------------------------------------------------
3175 ;;; (ti::file-name-forward-slashes-cygwin "f:/filename")
3177 (defsubst ti::file-name-forward-slashes-cygwin (file)
3178 "Convert Win32 F:\\filename to /cygdrive/drive-letter/filename."
3180 (setq file (ti::file-name-forward-slashes file))
3181 (while (when (string-match "\\(\\([a-zA-Z]\\):\\)\\([\\/].*\\)" file)
3182 (setq file (replace-match (concat "/cygdrive/"
3184 (match-string 2 file)))
3189 ;;; ----------------------------------------------------------------------
3190 ;;; The lisp primitive call isn't very descriptive. This short
3191 ;;; macro looks better in code.
3193 (defsubst ti::file-changed-on-disk-p (&optional buffer)
3194 "Check if BUFFER's file has recently changed on disk."
3195 (not (verify-visited-file-modtime
3196 (or (current-buffer) buffer))))
3198 ;;; ----------------------------------------------------------------------
3200 (defsubst ti::file-mode-make-read-only (mode)
3201 "Make MODE bit user read-only."
3204 ;;; ----------------------------------------------------------------------
3206 (defsubst ti::file-mode-make-read-only-all (mode)
3207 "Make MODE bit read-only to all."
3208 (logand mode 292)) ;444oct
3210 ;;; ----------------------------------------------------------------------
3212 (defsubst ti::file-mode-make-writable (mode)
3213 "Raise MODE bit's write flag."
3216 ;;; ----------------------------------------------------------------------
3218 (defsubst ti::file-mode-make-executable (mode)
3219 "Raise MODE bit's executable flag."
3220 (logior mode 64)) ;oct 100
3222 ;;; ----------------------------------------------------------------------
3224 (defsubst ti::file-mode-protect (file &optional mode)
3225 "Set FILE modes to -rw------- or if MODE is non-nil to -r--------."
3228 (mode (set-file-modes file 256)) ;; 400oct
3229 (t (set-file-modes file 384)))) ;; 600oct
3231 ;;; ----------------------------------------------------------------------
3233 (defsubst ti::file-toggle-read-write (mode)
3234 "Toggle MODE bit's user write flag."
3235 (if (eq 0 (logand mode 128)) ;-r-------- , 400 oct, 256 dec
3236 (ti::file-mode-make-writable mode) ;R --> W 200
3237 (ti::file-mode-make-read-only mode))) ;W --> R, 577
3239 ;;; ----------------------------------------------------------------------
3241 (defsubst ti::file-owned-p (file)
3242 "Test if current `user-uid' [uid] owns the FILE."
3243 (eq (user-uid) (nth 2 (file-attributes file))))
3245 ;;; ----------------------------------------------------------------------
3246 ;;; - If you own the file, you can turn on the write flag..
3248 (defsubst ti::file-modify-p (file)
3249 "Test if we can modify FILE. It must be file, not dir, owned by us."
3250 (and (file-exists-p file)
3251 (ti::file-owned-p file)))
3253 ;;; ----------------------------------------------------------------------
3254 ;;; - I do this so often that a macro is handy
3256 (defsubst ti::file-find-file-p (file)
3257 "Check if FILE is loadable, like C-x C-f. Non-string args are accepted too.
3258 The FILE is not expanded."
3260 (file-readable-p file)))
3262 ;;; ----------------------------------------------------------------------
3264 (defsubst ti::file-read-only-p (file)
3265 "Check if FILE is read only.
3266 Only checks if there is no +w flags,other flags are not checked.
3268 E.g. you may have permissions ---x------ which this function
3269 reports as read-only, bcause there is no +w flags on."
3271 (if (not (file-exists-p file))
3272 (error "No file '%s'" file)
3273 (if (null (setq modes (file-modes file)))
3274 (error "File modes failed?")
3276 ;; 222oct is 146dec "--w--w--w" if any of these write flags
3277 ;; is on, then this returns true.
3279 (if (eq 0 (setq modes (logand modes 146)))
3283 ;;; ----------------------------------------------------------------------
3285 (defun ti::file-name-run-real-handler (caller-sym operation args)
3286 "You can call this function only from `file-name-handler-alist' handler.
3287 See Info page Node: Magic File Names.
3291 CALLER-SYM the caller's function symbol
3292 OPERATION handler operation, see info page.
3294 (let ((inhibit-file-name-handlers
3295 ;; Prevent infinite loop, don't call my-handler again.
3297 (and (eq inhibit-file-name-operation operation)
3298 inhibit-file-name-handlers)))
3299 (inhibit-file-name-operation operation))
3300 (apply operation args)))
3302 ;;; ----------------------------------------------------------------------
3303 ;;; See also insert-file-contents-literally
3305 ;;; - The problem with "loading into emacs" is that all kinds of hooks
3306 ;;; are run, e.g. folding and outline might get activated when the file is
3307 ;;; loaded. E.g. if we do eval, it can't see the functions if they are
3308 ;;; behind selective display.
3310 (defun ti::find-file-literally (file &optional buffer verb)
3311 "Like `find-file' but disable everything which might affect loading.
3312 No hooks are run, no other special setups.
3314 If there existed same file, the buffer name will reflect the file name
3315 with letters \"<2>\" or so.
3320 BUFFER optional buffer where to insert the file
3321 VERB displays buffer. This is on when called interactively.
3326 (interactive "fFind file: ")
3327 (let* ( ;; This mode does not run any hooks.
3328 (default-major-mode 'fundamental-mode)
3329 ;; This makes sure we truly load the file.
3330 ;; If there were that file in emacs, emacs won't load it.
3331 (fn (file-name-nondirectory file))
3332 ;; Prohibit emacs from doing anything fancy while
3335 ;; jka doen't use this, but crypt++ does. Prevent running mode hooks
3337 (find-file-hooks (if (featurep 'crypt++) '(crypt-find-file-hook)))
3341 (setq buffer (generate-new-buffer fn)))
3342 (if (featurep 'crypt++)
3343 (progn (with-current-buffer (setq tmp (find-file-noselect file))
3344 (copy-to-buffer buffer (point-min) (point-max)))
3345 (ti::kill-buffer-safe tmp))
3346 (with-current-buffer buffer
3347 (insert-file-contents file)))
3348 (with-current-buffer buffer
3350 (switch-to-buffer buffer))
3351 (set-buffer-modified-p nil)
3352 (setq buffer-file-name (expand-file-name file)))
3355 ;;; ----------------------------------------------------------------------
3357 (defun ti::file-eval (file)
3358 "Like `load-file', but read FILE and eval it in temporary buffer.
3360 The advantage over `load-file' is that physical loading also uncompresses
3361 the file if there is proper elisp package to handle it, thus your elisp
3362 can be in any file *form* that packages allow for loading."
3364 (setq buffer (ti::find-file-literally file))
3365 (with-current-buffer buffer
3366 (if (and (ti::xemacs-p) ;XEmacs compatibility
3367 (fboundp 'eval-buffer))
3368 (ti::funcall 'eval-buffer)
3369 (ti::funcall 'eval-current-buffer)))
3370 (kill-buffer buffer)))
3372 ;;; ----------------------------------------------------------------------
3374 (defun ti::directory-writable-p (file-or-dir)
3375 "Check if FILE-OR-DIR is writable."
3376 (let* ((dir (file-name-directory (expand-file-name file-or-dir)))
3378 (fn (concat dir file)))
3379 (if (not (stringp file))
3380 (error "invalid arg"))
3381 (file-writable-p fn)))
3383 ;;; ----------------------------------------------------------------------
3384 ;;; - When removing temporary files; I don't care if they succeed or not
3386 (defun ti::file-delete-safe (files)
3387 "Deletes file or list of FILES. Read only files are chmod'd to writable.
3388 All errors are ignored."
3389 (let* ((list (ti::list-make files))
3393 (when (file-exists-p file)
3394 (setq mods (ti::file-mode-make-writable (file-modes file)))
3395 (set-file-modes file mods)
3396 (delete-file (car list)))))))
3398 ;;; ----------------------------------------------------------------------
3400 (defun ti::temp-directory ()
3401 "Return temporary directory."
3402 (or (getenv "TEMPDIR")
3404 (and (boundp 'temporary-file-directory) ;; Emacs var
3405 (let ((val (symbol-value 'temporary-file-directory)))
3406 (when (and (stringp val)
3407 (file-directory-p val))
3409 (and (file-directory-p "c:/temp") "c:/temp")
3410 (and (file-directory-p "/tmp") "/tmp")
3411 (and (file-directory-p "/temp") "/temp")
3413 "Tinylib: Cannot suggest temporary directory. Set TEMPDIR.")))
3415 ;;; ----------------------------------------------------------------------
3416 ;;; - The buffer is *not* cleared, only put to consistent state
3418 (defun ti::temp-file (file &optional find-temp-dir)
3419 "Prepare temporary FILE for use. Delete old file with the same name.
3420 Ensure you have write permission to the file.
3421 Aborts with error if can't prepare the conditions to use FILE.
3426 FIND-TEMP-DIR Flag, Use /tmp or system (win32) specific tmp dir
3427 Any path in FILE is replaced with temp dir."
3430 (setq dir (ti::temp-directory))
3431 (setq file (ti::file-make-path dir (file-name-nondirectory file))))
3433 (if (file-exists-p file)
3435 ;; See if the we have permissions to dir to write this new file ?
3436 (if (not (file-writable-p file))
3437 (error "Can't write to file")))
3440 ;;; ----------------------------------------------------------------------
3442 (defun ti::pop-to-buffer-or-window (buffer &optional point)
3443 "Like `pop-to-buffer' BUFFER and POINT, but find any visible window."
3445 (setq win (get-buffer-window buffer t))
3447 (pop-to-buffer buffer)
3448 (raise-frame (window-frame win))
3449 (select-frame (window-frame win))
3452 (goto-char point)))))
3454 ;;; ----------------------------------------------------------------------
3456 (defun ti::find-file-or-window (file &optional line must-exist other-win)
3457 "Visit FILE and LINE.
3458 If there already is window for the file, pop to it. Otherwise
3459 behave like `find-file'.
3464 LINE line nuumber where to position point
3465 MUST-EXIST Flag, if non-nil, return nil if file does not exist
3466 either in disk or in Emacs.
3467 OTHER-WIN display in other window."
3468 (let* ((buffer (or (find-buffer-visiting file)
3471 ;; We may have mistakenly grabbed 'cd' command and
3472 ;; stucked it with buffers name.
3473 ;; /users/foo/*scratch* --> *scratch*
3475 (get-buffer (file-name-nondirectory file))))
3477 ;; If buffer exists and is diplayed in another frame, use it.
3479 (win (and buffer (get-buffer-window buffer t))))
3481 (unless (and buffer win)
3482 (when (or (file-exists-p file)
3483 (null must-exist)) ;Not exist, but still ok
3484 (ti::select-frame-non-dedicated) ;Can't do find file otherwise
3486 (find-file-noselect file))))
3490 (display-buffer buffer)
3491 (ti::pop-to-buffer-or-window buffer))
3492 (select-window (get-buffer-window buffer))
3501 ;;; ----------------------------------------------------------------------
3503 (defsubst ti::mouse-point (&optional event)
3504 "Return mouse's working point. Optional EVENT is a mouse click."
3505 (if (or mouse-yank-at-point
3510 (ti::funcall 'posn-point (ti::funcall 'event-start event)))))
3513 ;;{{{ special: i-macros for interactive
3515 ;;; #todo: rethink i-macros someday. Are they necessary?
3517 ;;; You put these macros inside 'interactive'
3519 ;;; (defun test (beg end)
3520 ;;; (interactive (tipgp-i-region-ask-macro))
3521 ;;; ;; code continues
3524 ;;; ----------------------------------------------------------------------
3526 (defsubst ti::i-macro-region-ask (&optional prompt)
3527 "Macro, usually called from 'interactive' command.
3528 Ask to include whole buffer with PROMPT if region is not selected. If there is
3529 no region given, signal error.
3535 (list (region-beginning) (region-end)))
3539 "Hmmm.. no region selected. Use whole buffer? "))
3540 (list (point-min) (point-max)))
3542 (error "No region."))))
3544 ;;; ----------------------------------------------------------------------
3546 (put 'ti::i-macro-region-body 'lisp-indent-function 0)
3547 (defmacro ti::i-macro-region-body (&rest body)
3548 "Macro, usually called from 'interactive' command.
3549 Return selected region and execute BODY. Signal error if
3550 region is not selected.
3553 '(beg end BODY-return-value)"
3555 (if (null (region-active-p))
3556 (error "No region selected.")
3563 ;;{{{ FORMS: special
3565 ;;; ----------------------------------------------------------------------
3567 (put 'ti::with-unix-shell-environment 'lisp-indent-function 0)
3568 (put 'ti::with-unix-shell-environment 'edebug-form-spec '(body))
3569 (defmacro ti::with-unix-shell-environment (&rest body)
3570 "Run BODY in Unix like shell. In Win32, this means using Cygwin.
3571 This form does not guarrantee the environment if there isn't none.
3573 Variable `shell-file-name' is bound locally to new value."
3575 (let ((shell-file-name shell-file-name))
3576 ;; In cygwin, programs like zgrep and egrep are
3577 ;; shell scripts, which cannot be called (they should be .exe)
3578 ;; in Win32, when cmdproxy.exe is used.
3580 ;; Try to change the context if user has Cygwin.
3582 (let ((cygwin (ti::win32-cygwin-p)))
3583 (setq shell-file-name (format "%s/bin/bash.exe" cygwin))))
3586 ;;; ----------------------------------------------------------------------
3587 ;;; so that I can keep the URL link in one place.
3589 (put 'ti::package-defgroup-tiny 'lisp-indent-function 3)
3590 (defmacro ti::package-defgroup-tiny (symbol prefix group &optional doc)
3591 "Define defcustom.el group for tiny* files.
3595 SYMBOL The package's defgroup name
3596 PREFIX Package's variable prefix
3597 GROUP The upper level custom group where SYMBOL belong
3599 DOC Group documentation string."
3601 (defgroup (, symbol) nil
3604 ;; You could also use (url-link "mailto:foo.bar@example.com")
3606 :link '(url-link :tag "Update site"
3607 "http://nongnu.org/projects/emacs-tiny-tools/")
3608 :prefix (symbol-name (quote (, prefix)))
3609 :group (quote (, group))
3611 ;; Now define custom contact function when you click link
3614 :tag "Contact maintainer"
3616 (symbol-name (quote (, prefix)))
3617 (symbol-name (quote (, symbol))))
3618 :action ti::package-tiny-defgroup-mail))))
3620 ;;; ----------------------------------------------------------------------
3621 ;;; This would actually belong to ti::package-defgroup-tiny
3623 ;;; The following autoload tells that function exists (used in function)
3626 ;; For some reason Emacs 19.30 doesn't see :func-args
3627 ;; as class parameter if compiled without custom? Hm. Any ideas,
3628 ;; how to tell that it is not a variable?
3630 (when (and (not (fboundp 'widget-get))
3632 (eq emacs-minor-version 30)))
3634 tinylibm.el: ** ignore following byte compiler message if you see it
3635 ** 'reference to free variable :func-args'")))
3637 ;;; ----------------------------------------------------------------------
3639 (defun ti::package-tiny-defgroup-mail (widget &rest ignore)
3640 "Called from defcustom/defgroup with WIDGET and IGNORE rest args.
3641 Send mail to tiny* package maintainer. Read keyword :func-args
3642 which should hold elements
3644 '(list PACKAGE-PREFIX PACKAGE-NAME) ;; nth 0 \"list\" is ignored.
3646 The PACKAGE-PREFIX is in format \"xxx-:\" where a contact function
3647 name `PACKAGE-PREFIX-submit-bug-report' is derived."
3649 ;; Due to ti::funcall, functions must not be in autoload state.
3653 (let* ((args (ti::funcall 'widget-get widget ':func-args)) ;; #TODO
3654 (arg1 (eval (nth 1 args)))
3657 ;; from variable pfx "tipgp-:" --> to function prefix "tipgp-"
3658 (pfx (substring arg1 0 (1- (length arg1))))
3659 (func (concat pfx "submit-bug-report"))
3661 (if (setq sym (intern-soft func))
3662 (call-interactively sym)
3663 (message "Can't find contact function %s. Load %s.el first."
3664 func (concat (downcase arg2) ".el"))
3667 ;;; ----------------------------------------------------------------------
3669 (put 'ti::grep-output-parse-macro 'lisp-indent-function 1)
3670 (put 'ti::grep-output-parse-macro 'edebug-form-spec '(body))
3671 (defmacro ti::grep-output-parse-macro (buffer &rest body)
3672 "In current buffer, run BODY for every 'grep' line.
3673 Point is set to point-min. The BODY must not change BUFFER's point.
3675 Following variables are bound during loop (lowercase variable names):
3678 GREP-FILE:GREP-LINE:GREP-DATA
3680 This means that you can say this in BODY.
3682 (setq absolute (concat grep-dir grep-file))"
3683 (` (with-current-buffer (, buffer)
3686 (let ((grep-dir (and (looking-at "^cd +\\(.*\\)")
3691 (while (re-search-forward
3692 "^\\([^:\r\n]+\\):\\([0-9]+\\):\\(.*\\)" nil t)
3693 (setq grep-file (match-string 1)
3694 grep-line (match-string 2)
3695 grep-data (match-string 3))
3698 (setq grep-line (string-to-int grep-line)))
3703 ;; cd /usr/lib/perl5/5.6.1/pods/
3704 ;; grep finished (matches found) at Tue Jul 23 17:39:21
3706 (unless (looking-at "^cd \\|^[^ \t\n\r]+ +finished")
3708 (forward-line 1)))))))
3710 ;;; ----------------------------------------------------------------------
3712 (put 'ti::occur-macro 'lisp-indent-function 2)
3713 (put 'ti::occur-macro 'edebug-form-spec '(body))
3714 (defmacro ti::occur-macro (re &optional hook &rest body)
3715 "Run occur with RE starting from `point-min' and call HOOK after BODY.
3717 Execute BODY after occur statement in occur buffer.
3718 Run HOOK in occur buffer last; this arg can also be nil if there is no hook."
3721 (save-excursion ;save user's active point
3724 (pop-to-buffer "*Occur*")
3728 (run-hooks (quote (, hook)))))))
3730 ;;; ----------------------------------------------------------------------
3732 (defun-maybe shell-command-to-string (command)
3733 "Returns shell COMMAND's ouput as string. Tinylibm."
3735 (shell-command command (current-buffer))
3738 ;;; ----------------------------------------------------------------------
3739 ;;; #todo: should use help-mode ?
3741 (put 'ti::momentary-output-macro 'lisp-indent-function 3)
3742 (put 'ti::momentary-output-macro 'edebug-form-spec '(body))
3743 (defmacro ti::momentary-output-macro
3744 (buffer &optional echo-msg win1 &rest body)
3745 "Momentarily execute body in buffer.
3746 You normally use this to display messages to user.
3747 Buffer is buried after this form finishes.
3749 The output is accomplished using `with-output-to-temp-buffer', so
3750 you have to use 'princ' to write output.
3755 ECHO-MSG displayed at echo area. If nil, default message is used.
3756 WIN1 flag, if non-nil, occupie full window
3757 BODY rest of the Lisp code.
3761 (ti::momentary-output-macro
3762 \"*notes*\" \"howdy! Press some key\" nil
3763 (princ \"This is the message\"))"
3766 (save-window-excursion
3767 (with-output-to-temp-buffer (, buffer)
3769 (select-window (get-buffer-window (, buffer)))
3771 (delete-other-windows (get-buffer-window (, buffer))))
3772 (ti::read-char-safe-until
3773 (or (, echo-msg) "Press something to delete window."))
3774 (bury-buffer (, buffer))))))
3776 ;;; ----------------------------------------------------------------------
3777 ;;; - Sometimes you just want to switch buffer temporarily and
3778 ;;; set point to somewhere else, like scroll a buffer
3780 (put 'ti::save-excursion-macro 'lisp-indent-function 0)
3781 (put 'ti::save-excursion-macro 'edebug-form-spec '(body))
3782 (defmacro ti::save-excursion-macro (&rest body)
3783 "Like `save-excursion` BODY, but return to original window.
3784 No other values are preserved. Also the `select-window'
3785 is executed if the original buffer had `window-live-p'. (ie. it was visible)
3787 Use this if you want to e.g. scroll some buffer."
3789 (let* ((oRig-Buf (current-buffer))
3790 (oRig-Win (get-buffer-window oRig-Buf)))
3794 (set-buffer oRig-Buf) ;restore buffer.
3795 (when (and (windowp oRig-Win) ;no window visible
3796 (window-live-p oRig-Win))
3797 ;; and the visible window
3798 (select-window oRig-Win))))))
3800 ;;; ----------------------------------------------------------------------
3802 (put 'ti::save-with-marker-macro 'lisp-indent-function 0)
3803 (put 'ti::save-with-marker-macro 'edebug-form-spec '(body))
3804 (defmacro ti::save-with-marker-macro (&rest body)
3805 "Save the line position by using the marker and execute BODY.
3806 Marker is assigned to current position. Caution: If you delete text where the
3807 marker is, there is no way to set the previous point. In this case the
3808 results are undefined.
3812 Make sure you don't insert to immediate marker position, because
3813 markers moves along with the text!"
3815 (let* ((MarK (point-marker)))
3818 (when (marker-position MarK)
3819 (goto-char (marker-position MarK)))))))
3821 ;;; ----------------------------------------------------------------------
3823 (put 'ti::save-line-column-macro 'lisp-indent-function 2)
3824 (put 'ti::save-line-column-macro 'edebug-form-spec '(body))
3825 (defmacro ti::save-line-column-macro (fail-form col-form &rest body)
3826 "Save line and column position.
3827 When you kill/add lines from buffer, you cannot normally save the current
3828 point with `save-excursion', since the point no longer is the
3829 same spot or it may be have been deleted.
3831 This macro saves the position by remembering line and column position.
3835 (fail-form col-form &rest body)
3839 If the line position cannot be preserved, Then FAIL-FORM is evaled: it can
3840 put the cursor at desired place.
3842 If column position cannot be preserved COL-FORM is evaled.
3846 ;; 1st and 2nd forms act like no-ops after erase buffer command
3847 (ti::save-line-column-macro nil nil (erase-buffer))
3849 ;; 1st: Put cursor at the be.g. of buffer when failure.
3850 ;; 2nd: If col is missed, put cursor at be.g. of line
3851 ;; 3rd: The form executed is all the rest of the lines
3853 (ti::save-line-column-macro
3854 (goto-char (point-min))
3856 (flush-lines \"*\\.txt\"))
3860 Last value returned by BODY"
3861 (` (let* ((SLC-sLc-col (current-column)) ;prevent variable suicide
3862 (SLC-sLc-line (ti::current-line-number)))
3865 (goto-line SLC-sLc-line)
3866 (move-to-column SLC-sLc-col)
3868 ((not (eq (ti::current-line-number) SLC-sLc-line))
3870 ((not (eq (current-column) SLC-sLc-col))
3873 ;;; ----------------------------------------------------------------------
3875 (put 'ti::widen-safe 'lisp-indent-function 0)
3876 (put 'ti::widen-safe 'edebug-form-spec '(body))
3877 (defmacro ti::widen-safe (&rest body)
3878 "(&rest body) Widen buffer end execute BODY.
3879 Preserves possible narrowing when done.
3881 The BODY is not protected against errors or surrounded by `save-excursion'
3886 (` (let ((BeG (point-min-marker))
3887 (EnD (point-max-marker))
3888 (EnD-max (point-max))
3894 (setq EnD-wmax (point-max))
3895 (setq ReT (progn (,@ body))))
3896 (with-current-buffer (marker-buffer BeG)
3897 ;; what about after widen ? Were we in narrow mode ?
3898 (if (not (= EnD-wmax EnD-max))
3899 (narrow-to-region BeG EnD))
3901 (if (null ReT) ;no-op, Silence XEmacs 19.14 ByteComp.
3909 ;;; ----------------------------------------------------------------------
3912 (defun ti::package-config-file-directory-default ()
3913 "Determine default configuration file directory.
3914 The preferred locations are ~/elisp/config ~/lisp/config
3915 ~/elisp ~/lisp ~/tmp and last ~/.
3917 In XEmacs ~/.xemacs/config is preferred first."
3927 ;; Last resort if this is Win32 Emacs and
3928 ;; HOME is not set ("~" did not expand)
3931 (when (and (stringp dir)
3932 (file-directory-p dir))
3935 (defvar tinylib-:package-config-file-directory
3936 (ti::package-config-file-directory-default)
3937 "*Directory where to save configuration files.")
3939 (defvar tinylib-:package-config-file-prefix "emacs-config-"
3940 "*Prefix to add to configuration files. Default 'emacs-config-'.")
3942 (defun ti::package-config-file-prefix (&optional file &optional os emacs)
3943 "Return directory and prefix with config FILE optionally for OS and EMACS
3945 The default value is currenly combination of
3946 `tinylib-:package-config-file-directory' and
3947 `tinylib-:package-config-file-prefix'
3949 In packages, when defining a config file location, it is usually wanted
3950 that all packages save configuration files to the same location, so that it
3951 it not needed to configure each packages' files manually. The following
3952 code shows how package can define the configuration files in a bad and good
3955 ;; Bad name. Traditional dot-something in User's root (HOME)
3957 (defvar xxx-config-file \"~/.something\")
3959 ;; A much better way
3961 (defvar xxx-config-file (package-config-file-prefix \".something\"))
3965 Sometimes the configuration file needs operating system
3966 version (OS) and Emacs version. Supply non-nil (t) values for these if you
3967 need exactly a specific file for Win32/Unix and for XEmacs/Emacs."
3968 (when tinylib-:package-config-file-directory
3969 (unless (file-exists-p tinylib-:package-config-file-directory)
3970 (error "`tinylib-:package-config-file-directory' %s does not exist."
3971 tinylib-:package-config-file-directory))
3972 (format "%s%s%s%s%s"
3973 (file-name-as-directory tinylib-:package-config-file-directory)
3974 tinylib-:package-config-file-prefix
3982 (if (ti::emacs-p) "emacs" "xemacs")
3983 (ti::emacs-version-number-as-string))
3987 ;;; ----------------------------------------------------------------------
3989 (put 'ti::overlay-require-macro 'lisp-indent-function 0)
3990 (put 'ti::overlay-require-macro 'edebug-form-spec '(body))
3991 (defmacro ti::overlay-require-macro (&rest body)
3992 "Try to load overlay support or run BODY.
3993 Overlays are Emacs thingies, XEmacs uses extents. In XEmacs
3994 the overlay support is tested by loading package overlay.el and if it
3995 fails, then BODY is run.
4000 (ti::overlay-require-macro
4001 (message \"*** package.el: Your Emacs doesn't have overlay support.\")
4002 (error \"Compilation aborted.\")))"
4004 (when (and (ti::xemacs-p)
4005 ;; No overlay functions?.
4006 (not (fboundp 'overlays-at)))
4007 (load "overlay" 'noerr)) ;; has no provide statement
4008 (or (fboundp 'overlays-at) ;; Did it define this function?
4012 ;;; ----------------------------------------------------------------------
4014 (defun ti::pp-variable-list (list &optional buffer def-token)
4015 "Print LIST of variables to BUFFER. DEF-TOKEN defaults to `defconst'."
4019 (setq buffer (current-buffer)))
4022 (setq def-token "defconst"))
4025 (unless (symbolp sym)
4026 (error "List member is not symbol %s" sym))
4027 (setq val (symbol-value sym))
4028 (insert (format "\n\n(%s %s\n" def-token (symbol-name sym)))
4033 (insert (format "\"%s\"" val)))
4035 (insert (symbol-name val)))
4038 (insert "(function " (symbol-name val) ")"))
4040 (insert "'" (symbol-name val)))
4042 (insert "'" (pp val))))
4044 (error "unknown content of stream" sym val)))
4047 ;;; ----------------------------------------------------------------------
4049 (defun ti::write-file-variable-state (file desc list &optional fast-save bup)
4050 "Save package state to FILE.
4055 DESC One line description string for the file.
4056 LIST List of variable symbols whose content to save to FILE.
4058 FAST-SAVE The default `pp' function used to stream out the contents
4059 of the listp variables is extremely slow if your variables
4060 contain lot of data. This flag instructs to use alternative,
4061 much faster, but not pretty on output, method.
4063 BUP If non-nil, allow making backup. The default is no backup."
4065 (let ((backup-inhibited (if bup nil t)))
4066 (insert ";; @(#) " file " -- " desc "\n"
4068 (ti::date-standard-date 'short)
4071 (ti::pp-variable-list list)
4073 (insert (format "\n\n(defconst %s\n" (symbol-name var)))
4074 ;; While `pp' would have nicely formatted the value, It's
4075 ;; unbearable SLOW for 3000 file cache list.
4076 ;; `prin1-to-string' is 10 times faster.
4077 (insert "'" (prin1-to-string (symbol-value var)) ")\n")))
4078 (insert (format "\n\n;; end of %s\n" file))
4079 ;; prohibit Crypt++ from asking confirmation
4080 (ti::write-file-with-wrapper file))))
4086 ;;; tinylibm.el ends here