1 ;;; tinylib.el --- Library of general functions
3 ;; This file is not part of Emacs
7 ;; Copyright (C) 1995-2007 Jari Aalto
8 ;; Keywords: extensions
10 ;; Maintainer: Jari Aalto
12 ;; To get information on this program, call M-x tinylib-version
13 ;; Look at the code with folding.el
17 ;; This program is free software; you can redistribute it and/or modify it
18 ;; under the terms of the GNU General Public License as published by the Free
19 ;; Software Foundation; either version 2 of the License, or (at your option)
22 ;; This program is distributed in the hope that it will be useful, but
23 ;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
24 ;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
27 ;; You should have received a copy of the GNU General Public License
28 ;; along with program; see the file COPYING. If not, write to the
29 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
30 ;; Boston, MA 02110-1301, USA.
32 ;; Visit <http://www.gnu.org/copyleft/gpl.html> for more information
39 ;; ........................................................ &t-install ...
40 ;; Put this file to the package that you're developing. This file is
41 ;; is mostly for developers.
43 ;; (require 'tinylibm) ;; No mistake here, you load `m' library
45 ;; If you have any questions or feedback, use this function
47 ;; M-x tinylib-submit-feedback
52 ;; ..................................................... &t-commentary ...
58 ;; This is library, so the package itself does nothing,
59 ;; there may be some interactive functions.
60 ;; There is a issue of Emacs and XEmacs differences multiplied with
61 ;; different OS platforms, like Cygwin and native Win32. In order to
62 ;; reuse the code in modules and to keep up with the Emacs/XEmacs
63 ;; interface and different releases, the general function can be found
64 ;; from these libraries.
66 ;; Defining a minor mode
68 ;; This library provides Emacs/XEmacs comatible minor mode
69 ;; since 1995. There is one macro that defines all minor mode
70 ;; variables and function.
72 ;; (eval-and-compile ;; So that defvars and defuns are seen
73 ;; (ti::macrof-minor-mode-wizard
75 ;; ;; 1. prefix for variables and functions
76 ;; ;; 2. Modeline name
77 ;; ;; 3. prefix key for mode.
78 ;; ;; 4. Menu bar name
79 ;; ;; 5. <forget this>
81 ;; "xxx-" " xxxModeline" "\C-cx" "xxxMenubar" nil
83 ;; "XXX minor mode. Does fancy things." ;; mode description
88 ;; "XXX help" ;; message displayed when user calls mode
89 ;; nil ;; Forms When minor mode is called
91 ;; ;; This is used by easy-menu.el and defines menu items.
93 ;; xxx-mode-easymenu-name
94 ;; ["Eval whole buffer" xxx-eval-current-buffer t]
97 ;; ;; this block defines keys to the mode. The mode minor map is
98 ;; ;; locally bound to 'map' symbol.
100 ;; (define-key map "-" 'xxx-eval-current-buffer)
101 ;; (define-key map "=" 'xxx-calculate))))
103 ;; Defining minor mode step by step
105 ;; If you want to take more personal control over the minor mode
106 ;; creation, here I explain step by step what macros you need to include
107 ;; in your package to get minor mode created, This takes only
108 ;; half an hour and you have basic minor mode ready. Put all
109 ;; following calls near top of your file. We suppose we're
110 ;; creating XXX-mode.
112 ;; _[1]_ First, define standard variables for minor mode.
114 ;; (ti::macrov-minor-mode "xxxModeline" "\C-cx" "xxxMenubar")
116 ;; After that user has following varibles for customization. (for
117 ;; complete list of created variables, see the macro's description)
119 ;; ;; Don't like default key combo C-c x
120 ;; (setq xxx-mode-prefix-key "\C-cm")
122 ;; ;; The default mode string was too long, use shorter.
123 ;; (setq xxx-mode-name "xxx")
125 ;; ;; When mode runs, I want to do this.
126 ;; (add-hook 'xxx-mode-hook 'my-xxx-settings)
128 ;; ;; I want to add additional keys
129 ;; (add-hook 'xxx-mode-define-keys-hook 'my-xxx-keys)
131 ;; _[2]_ Next we need installation function, which installs our minor
132 ;; mode so that emacs is aware of it. The minor mode functions,
133 ;; xxx-mode, will call xxx-mode-define-keys-hook which takes care of
134 ;; defining keys to key maps and creating menus with easy-menu.el. The
135 ;; separate installation function is used, because it takes care of
136 ;; emacs specific things and if called with additional argument, it
137 ;; also knows how to remove the mode gracefully.
139 ;; (ti::macrof-minor-mode-install
144 ;; xxx-mode-define-keys-hook)
146 ;; _[3]_ Do we have additional files attached to the end of package?
147 ;; If yes, then we need pgp-tar unpack function too.
149 ;; (ti::macrof-install-pgp-tar "xxx-install-files" "xxx.el")
151 ;; _[4]_ Finally the user callable minor mode function is created.
153 ;; (ti::macrof-minor-mode
155 ;; "XXX minor mode. Does fancy things."
162 ;; xxx-mode-prefix-key
164 ;; nil ;Yes, print turn on/off message
168 ;; That's it. when you execute all these statements you have basic core
169 ;; for emacs minor mode. The only things missing is the actual
170 ;; functions that the minor mode commands uses and the function that
171 ;; defines keys and menus for the minor mode. You probably want to
172 ;; start from the function that defines keys and menus. Here is ready
173 ;; macro for that too.
175 ;; (add-hook' xxx-mode-define-keys-hook 'xxx-mode-define-keys)
177 ;; (ti::macrof-define-keys
178 ;; "xxx-mode-define-keys"
179 ;; 'xxx-:mode-prefix-map
180 ;; 'xxx-:mode-prefix-key
183 ;; 'xxx-:easymenu-name
184 ;; "Programming help menu."
186 ;; xxx-:easymenu-name
187 ;; ["Eval whole buffer" xxx-eval-current-buffer t]
190 ;; (define-key map "-" 'xxx-eval-current-buffer)
191 ;; (define-key map "=" 'xxx-calculate)
202 ;;; ......................................................... &require ...
204 (require 'tinylibm) ;macro package
207 (ti::package-use-dynamic-compilation)
208 (when (and (ti::xemacs-p)
209 (byte-compiling-files-p))
211 ** tinylib.el: [Note] It is safe to ignore Emacs dependant ange-ftp function
212 compilation errors.")))
216 (defvar generated-autoload-file) ;; See autoload.el
217 (defvar flyspell-mode)
219 (autoload 'vc-name "vc-hooks")
220 (autoload 'vc-file-getprop "vc-hooks")
222 ;; Can't autoload timer, because various calls in this lib are behind
223 ;; ti::funcall --> Bytecompiler doesn't see them.
225 (ti::package-package-require-timer) ;XEmacs and Emacs differencies
230 ;; Ange-ftp function used in this package won't work in XEmacs.
231 ;; The ange functions used for backgroung ftp downloads
232 ;; and low level calling calling of ange functions. Currently used in
233 ;; one pacakge: tinydired.el, which let's you donwload/upload
234 ;; files at the background.
236 (require 'efs-auto nil 'noerr)
237 (autoload 'read-passwd "passwd" "" t))
240 (defvar ange-ftp-process-result nil)
241 (defvar ange-ftp-ascii-hash-mark-size 1024)
242 (defvar ange-ftp-binary-hash-mark-size 1024)
243 (defvar ange-ftp-process-busy nil)
244 (autoload 'ange-ftp-process-handle-line "ange-ftp")
245 (autoload 'ange-ftp-get-process "ange-ftp")
246 (autoload 'ange-ftp-ftp-name "ange-ftp")
247 (autoload 'ange-ftp-real-file-name-as-directory "ange-ftp")
248 (autoload 'ange-ftp-expand-dir "ange-ftp")
249 (autoload 'ange-ftp-ftp-process-buffer "ange-ftp")
250 (autoload 'ange-ftp-set-binary-mode "ange-ftp")
251 (autoload 'ange-ftp-send-cmd "ange-ftp")
252 (autoload 'ange-ftp-cd "ange-ftp")
253 (autoload 'ange-ftp-raw-send-cmd "ange-ftp"))))
256 ;;{{{ setup: -- variables
258 ;;; ....................................................... &v-private ...
260 (defconst ti::var-syntax-info
264 (?_ "Symbol, variables and commands")
265 (?. "Punctuation, separate symbols from one another")
266 (?( "Open parenthesis")
267 (?) "Close parenthesis")
268 (?\" "String quote, string as a single token")
270 (?/ "Character quote, only the character immediately following.")
271 (?$ "Paired delimiter, like string quote, chars between are not suppressed")
272 (?< "Comment starter")
274 (?@ "Inherit from standard syntax table"))
275 "Short syntax definition table ((CLASS . DESC) ..).")
277 ;;; ........................................................ &v-public ...
278 ;;; User configurable
280 (defvar ti::var-x-coord 170
281 "*Default X menu coordinate.")
283 (defvar ti::var-y-coord 170
284 "*Default X menu coordinate.")
286 ;; Make this invisible by default, note leading space.
287 (defvar ti::var-passwd-buffer " *passwd-entries*"
288 "*Contents of password file.")
291 ;;{{{ setup: -- version
293 ;;; ....................................................... &v-version ...
294 ;;; These are not library funcs, so they have normal 'tinylib-' prefix
296 (defconst tinylib-version
297 (substring "$Revision: 2.107 $" 11 15)
298 "Latest version number.")
300 (defconst tinylib-version-id
301 "$Id: tinylib.el,v 2.107 2007/05/07 10:50:07 jaalto Exp $"
302 "Latest modification time and version number.")
304 ;;; ----------------------------------------------------------------------
306 (defun tinylib-version (&optional arg)
307 "Show version information. ARG will instruct to print message to echo area."
309 (ti::package-version-info "tinylib.el" arg))
311 ;;; ----------------------------------------------------------------------
313 (defun tinylib-submit-feedback ()
314 "Submit suggestions, error corrections, impressions, anything..."
316 (ti::package-submit-feedback "tinylib.el"))
320 ;;; ########################################################### &funcs ###
324 ;;; ........................................................ &defsubst ...
325 ;;; inlined functions, they must be introduced before used
327 ;;; ----------------------------------------------------------------------
329 (defun ti::string-trim-blanks (string &optional middle)
330 "Strip leading, trailing and middle spaces.
333 MIDDLE if non-nil, trim blanks in the middle too and convert
335 (when (stringp string)
336 ;; Strip leading and trailing
337 (if (string-match "^[ \t\f\r\n]*\\(.+[^ \t\f\r\n]\\)" string)
338 (setq string (match-string 1 string)))
341 (setq string (replace-regexp-in-string "[\t\r\n]" " " string))
342 (setq string (replace-regexp-in-string " +" " " string)))
345 ;;; ----------------------------------------------------------------------
347 ;;; (ti::string-verify-ends "Z" "\\." "." 'beg)
348 ;;; (ti::string-verify-ends "dir" "/")
350 (defun ti::string-verify-ends (str re &optional add-str beg)
351 "Make sure STR match RE and add ADD-STR string to it when necessary.
352 if ADD-STR is not given, adds RE to the string.
354 Default is to check end of string, Optionally BEG of string.
355 The RE may not include anchors.
358 making sure directory has ending slash
359 (ti::string-verify-ends \"dir\" \"/\") --> \"dir/\"
361 Making sure, time is zero based:
362 (ti::string-verify-ends \"7\" \"0\" nil 'beg) --> \"07\"
364 This does not give you the rsult you assume!
365 because the second parameter, \" \", is regexp that is tried.
366 This function can't know that there is only \" \" space at front,
367 since the regexp dind't match.
369 (ti::string-verify-ends \" padd\" \" \" nil 'beg)
373 str possibly modified"
377 (add (or add-str re))) ;which one to add.
378 (if (string-match RE str)
384 ;;; ----------------------------------------------------------------------
385 ;;; - Originally there was own function for this; but now
386 ;;; it uses general func verify...
387 ;;; - The main purpose of this function is that when you cat words
388 ;;; together, you can be sure they have COUNT spaces.
389 ;;; - kinda sprintf...
391 (defsubst ti::string-add-space (str &optional end count)
392 "Add space to the beginning of STR if there isn't one.
393 Optionally adds to the END. COUNT is by default 1
395 If string length is 0, do nothing."
396 (let* ((count (or count 1))
397 (padd (make-string count ?\ )))
398 (ti::string-verify-ends str padd padd (not end))))
400 ;;; ----------------------------------------------------------------------
402 (defun ti::string-remove-whitespace (string)
403 "Squeezes empty spaces around beginning and end of STRING.
404 If STRING is not stringp, then returns STRING as is."
406 (replace-regexp-in-string
408 (replace-regexp-in-string
409 "[ \t\r\n]+\\'" "" string))))
411 ;;; ----------------------------------------------------------------------
413 (defun ti::string-mangle (string)
414 "Mangle STRING ie. make STRING unreadable.
415 Same mangling is performed for the same STRING. Mangling can't be reversed."
416 (let* ((ch-list (coerce string 'list))
418 ;; (coerce list 'string) to get list of ints to string
420 (abc "zaybxcwdveuftgshriqjpkolnm0918273645ZAYBXCWDVEUFTGSHRIQJPKOLNM")
425 (setq x (% (char-to-int ch) len))
426 (setq ret (concat ret (substring abc x (1+ x)))))
429 ;;; ----------------------------------------------------------------------
430 ;;; #todo: Use replace-regexp-in-string
432 (defsubst ti::string-regexp-delete (re str &optional level)
433 "Remove all that match RE from STR at subexpression LEVEL."
434 (while (string-match re str)
435 (setq str (ti::replace-match (or level 0) nil str)))
441 ;;; ##################################################### &Conversions ###
443 ;;; ----------------------------------------------------------------------
446 ;;; (message str) ;; suppose you don't know what's in there
448 ;;; and you get error... use (message (ti::string-format-percent str))
450 (defun ti::string-format-percent (str)
451 "Convert STR to message string, doubling diffucult charactes, like % and \\."
452 (let* ((len (length str))
459 ((string-match "[%\\]" str) ;only now do
462 (setq ch (aref str i)
463 ch-string (char-to-string ch)
466 (setq extra ch-string))
467 (setq ret (concat ret ch-string extra))
471 ;;; ----------------------------------------------------------------------
473 (defun ti::string-url-to-ange-ftp (str)
474 "Converts URL STR into ange ftp address.
478 ftp://some.site/pub/users/foo/emacs/some.el
479 ftp://some.site:/pub/users/foo/emacs/some.el
480 ftp://ftp@some.site/pub/users/foo/emacs/some.el
481 ftp://ftp@some.site:/pub/users/foo/emacs/some.el
485 /ftp@some.site:/pub/users/foo/emacs/some.el
498 (string-match "ftp:/\\(/.*@\\)\\([^/]+:\\)\\(/.*\\)" str)
499 (setq login (match-string 1 str) ;; case 3
500 host (match-string 2 str)
501 dir (match-string 3 str)
502 ret (concat login host dir)))
504 (and (string-match "ftp:/\\(/.*@\\)\\(.*\\)" str)
505 (setq login (match-string 1 str) ;; case 4
506 ref (match-string 2 str)))
507 (setq idx (ti::string-index ref ?/ ))
508 (setq host (or host (substring ref 0 idx)))
509 (setq dir (substring ref idx))
510 (setq ret (concat (or login "/ftp@") host ":" dir)))
511 ( ;; ftp://some.site/pub/users/foo/emacs/some.el
512 (and (string-match "ftp://\\([^@/]+\\)\\(:?/.*\\)" str)
513 (setq host (match-string 1 str)
514 dir (match-string 2 str)))
517 (if (ti::string-index dir ?:) "" ":") ;add colon if needed
521 (and (string-match "ftp://\\([^@:]+\\)$" str)
522 (setq host (match-string 1 str)))
523 (setq ret (concat "/ftp@" host ":/"))))
527 ;;; ----------------------------------------------------------------------
528 ;;; #todo: there seems to be c-backslash-region
530 (defun ti::buffer-backslash-fix-paragraph
531 (&optional target-column stop-func verb)
532 "Fix \\ lines in current paragraph.
533 The first \\ Tells what the target column is. If there is no \\ anywhere
534 in the paragraph, this function does nothing.
538 TARGET-COLUMN position backslashes to this column, if possible.
539 if \\[universal-argument] or negative number,
541 STOP-FUNC If this function returns non-nil, then stop adding
542 backslashes. It is called prior the line is handled.
543 VERB Verbose messages.
548 Here is another ;; Note missing \\
549 and \\ ;; Note, extra \\, should not be there
551 Will be formatted as:
553 This is \\ ;; Target column, when TARGET-COLUMN is nil
554 Here is another \\ ;; Because the target-cool couldn't be set.
559 This is ;; Ignored, no \\
560 Here is another \\ ;; Target starts here
564 Will be formatted as:
568 And still.. \\ ;; Added
573 All the lines in this procmail example are together, but it would be wrong
574 to add final \\ to the end of ')'. The STOP-FUNC can make sure about that.
577 :0 h # this is procmail code
584 (let* ((point (point))
585 (cs (or comment-start "[ \t]*"))
586 (stop-re (format "^\\(%s\\)?[ \t]*$" cs)) ;Paragraph end
587 (kill-it (or (ti::listp target-column)
588 (and (integerp target-column)
589 (< target-column 0))))
591 indent-tabs-mode ;No tabs allowed
598 ;; ............................................... paragraph start ...
600 (while (and (not (eobp))
601 (not (looking-at stop-re)))
603 ;; .................................... forward to first backslash ...
604 ;; Skip comment lines and emtuy line forward.
605 (while (and (not (eobp))
606 (looking-at stop-re))
608 (when (eq major-mode 'makefile-mode)
609 (if (looking-at ".*:") ;; Go path the TARGET: RULE
611 ;; ... ... ... ... ... ... ... ... ... ... .. &starting target-col ...
612 (save-excursion ;Find the starting \\
614 (while (and (not (eobp))
615 (not (looking-at ".*[\\][ \t]*$"))
616 (not (looking-at stop-re)))
619 (goto-char beg) ;We landed here
621 ((not (looking-at ".*[\\]"))
623 Fix backslash: Nothing to do; no \ mark at the paragraph beginning."))
625 (goto-char (match-end 0))
627 (setq col-target (or (and
628 ;; User gave this value
629 (integerp target-column)
632 (current-column))) ;; use column from code them
635 (delete-horizontal-space))
636 ;; there was old starting \\, but not in the right column. Fix it,
637 ;; but only if it was far left.
639 ;; txt txt \ ;; this line is too far right
640 ;; T \ ;; The target column user wanted was T
641 (when (and (null kill-it)
642 (not (eq (current-column) col-target)))
643 (delete-region (point) (line-end-position))
644 (move-to-column col-target)
645 (when (or (null stop-func)
647 (null (funcall stop-func))))
649 (unless (looking-at "$") ;Remove garbage
650 (delete-region (point) (line-end-position)))
652 ;; ... ... ... ... ... ... ... ... ... ... ... ... .. loop-lines . .
653 ;; Empty line terminates
656 (not (looking-at stop-re))
659 (null (funcall stop-func)))))
660 (save-excursion ;Peek next line
662 (setq ad-it (not (looking-at stop-re))))
663 ;; ... ... ... ... ... ... ... ... ... ... ... fix backslashes ...
666 (when (looking-at ".*[\\]")
667 (goto-char (match-end 0)) (backward-char 1)
669 (delete-horizontal-space)))
670 ((looking-at ".*[\\]")
671 (goto-char (match-end 0)) (backward-char 1)
672 (setq col-now (current-column))
673 ;; Where is the word start?
674 (skip-chars-backward " \t\\")
675 (untabify (point) (line-end-position))
676 (setq col-word (current-column))
678 ((and (eq col-now col-target)
681 (move-to-column col-now)
683 (delete-horizontal-space))
684 ((not (eq col-now col-target))
686 ;; GFile.here \ < This is further right
688 ((> col-word col-target)) ;Do nothing, can't "line up"
690 (move-to-column (min col-target col-now))
691 (delete-region (point) (line-end-position))
693 (ti::buffer-move-to-col col-target)
695 ;; ... ... ... ... ... ... ... ... ... ... .. no-continuation ..
696 (ad-it ;No previous "\" and next line exist
698 (delete-horizontal-space) ;Clear the EOL
699 ;; Only if there is no text, T is target, but next line has
704 (if (<= (current-column) col-target)
705 (ti::buffer-move-to-col col-target))
708 (goto-char point) ;Restore user position
712 (message "Fix backslash: backslashes removed."))
715 "Fix backslash: backslashes in column %d" col-target))))))
717 ;;; ----------------------------------------------------------------------
718 ;;; - in many C/C++ styles the variables are names so that they start
719 ;;; with lowercase letters and following ones are catenated + first char
721 ;;; - Function names may start with uppercase.
724 (defun ti::buffer-upcase-words-to-variable-names (beg end &optional case-fold)
725 "Does following conversion by searhing caps only words in region.
727 THE_COLUMN_NAME --> theColumnName
731 BEG END region bounds
732 CASE-FOLD the value of `case-fold-search'. nil means that the
733 upcase \"words\" are counted only. Non-nil accepts
734 seearching mixed case words."
735 (interactive "*r\nP")
736 (let* ((case-fold-search case-fold) ;; case is significant..
737 (ptable (syntax-table)) ;; previous
738 (table (make-syntax-table))
744 (narrow-to-region beg end)
746 ;; let's make sure the _ is not in a word class, put it
747 ;; into some other class for now.
749 (modify-syntax-entry ?_ "_" table)
750 (set-syntax-table table)
751 (while (re-search-forward "[A-Z][A-Z_]+" nil t)
752 (setq beg (match-beginning 0)
755 (setq f1 (looking-at "[ \t]\\|$"))
757 (setq f2 (looking-at "[ \t]\\|$")))
760 ;; make first word "lowercase only"
763 ;; handle next words, until space/eol/eob is seen
764 (while (and (not (eobp))
765 (not (looking-at "[ \t]\\|$")))
767 ;; Remove that underescore
768 ;; Capit. command moves forward while doing
770 (and (looking-at "_")
772 (capitalize-word 1)))))
773 ;; ... ... ... ... ... ... ... ... ... ... ... .. unwind end . .
774 ;; Now, make sure the old table is restored,
775 ;; the unwind protects against Ctrl-g
776 (set-syntax-table ptable))))
780 ;;; ----------------------------------------------------------------------
782 (defsubst ti::string-nth-from-number (nbr)
783 "Return string representing NBR position: st, nd, th.
786 string or number in digit form.
789 \"st\", \"nd\", \"th\""
791 (setq nbr (string-to-int nbr)))
798 (error "invalid ARG" nbr))))
800 ;;; ----------------------------------------------------------------------
802 ;;; - Did 19.29+ change the current-time function? Oh my...say no?
803 ;;; --> should handle it if the format changed.
805 (defun ti::date-time-elements (&optional zero-form time-string)
806 "Return list of elements derived from `current-time'.
807 This is old function, you should use newer `format-time-string'.
811 ZERO-FORM make sure numbers have preceeding zeroes. Like 7 --> 07
812 TIME-STRING user supplied time string in `current-time' format.
814 Return list form: \( dd mm ...\)
816 0 dd nbr, day if zero-form: ti::string-value
817 1 mm nbr, month if zero-form: ti::string-value
820 4 wd 3str, week day, string like 'Mon'
821 5 m str, month, full string
822 6 yyyy 4str, whole year"
824 (let (time m mm dd yy tt wd yyyy)
825 (setq time (or time-string
826 (current-time-string))) ;"Wed Oct 14 22:21:05 1987"
827 (setq wd (substring time 0 3))
828 (setq m (substring time 4 7))
829 (setq mm (or (ti::date-month-to-number m) 0))
830 ;; we remove trailing space "2 " --> 2 --> "2"
831 (setq dd (string-to-int (substring time 8 10)))
832 (setq tt (substring time -13 -8))
833 (setq yy (substring time -2 nil))
834 (setq yyyy (substring time -4 nil))
836 (zero-form ;convert "7" --> "07"
837 (setq dd (int-to-string dd))
838 (setq mm (int-to-string mm))
839 (if (not (eq (length dd) 2))
840 (setq dd (concat "0" dd)))
841 (if (not (eq (length mm) 2))
842 (setq mm (concat "0" mm)))))
843 (list dd mm yy tt wd m yyyy)))
845 ;;; ----------------------------------------------------------------------
846 ;;; - This is mainly used, if you read the regexp from the buffer:
847 ;;; obviously you can't just pick it from there:
851 ;;; and use it in re-search-XXX commands. See function ti::buffer-get-re
852 ;;; which does the conversion automatically by calling these functions.
854 (defun ti::string-char-to-escape-char (item)
855 "Converts ITEM to escape sequence \"t\" --> \"\\t\".
859 item integer, character, or single string
863 nil if cannot identify ITEM.
875 (setq item (char-to-string item)))
876 (if (setq el (assoc item table))
877 (setq ret (char-to-string (cdr el))))
880 ;;; ----------------------------------------------------------------------
882 (defun ti::string-plain-string-to-regexp (str)
883 "Convert slashes in STR \\\ --> \.
884 If you read from buffer two some special characters, it can't be
885 used like that right a way for regexp. E.g. in buffer \\\\ two slashes mean
886 one slash actually when assigned to string to form the regexp."
891 (prev-ch ?d) ;just some dummy
896 (setq ch (aref str i)
897 chs (char-to-string ch))
898 (if (eq ch look-ch) ;add counter when EQ
901 ((eq count 2) ;two successive ?
902 (if (eq prev-ch look-ch)
903 (setq count 0) ;delete second
904 (setq ret (concat ret chs))
908 ;; Right now it was found
909 (setq ret (concat ret chs))
910 ;; - Count is still 9, but we aren't looking at double \\ ?
911 ;; --> there is \t sequence
912 ;; - we revove last char and put our sequence instead
914 (substring ret 0 (1- (length ret)))
915 (ti::string-char-to-escape-char chs)))
918 (setq ret (concat ret chs))))
923 ;;; ----------------------------------------------------------------------
924 ;;; arc.mode.el -- This is from 19.28 distrib.
926 (defun ti::file-access-mode-to-string (mode)
927 "Turn an integer MODE, 0700 (i.e., 448) into a mode string like -rwx------."
928 (let ((str (make-string 10 ?-)))
929 (or (zerop (logand 16384 mode)) (aset str 0 ?d))
930 (or (zerop (logand 8192 mode)) (aset str 0 ?c)) ; completeness
931 (or (zerop (logand 256 mode)) (aset str 1 ?r))
932 (or (zerop (logand 128 mode)) (aset str 2 ?w))
933 (or (zerop (logand 64 mode)) (aset str 3 ?x))
934 (or (zerop (logand 32 mode)) (aset str 4 ?r))
935 (or (zerop (logand 16 mode)) (aset str 5 ?w))
936 (or (zerop (logand 8 mode)) (aset str 6 ?x))
937 (or (zerop (logand 4 mode)) (aset str 7 ?r))
938 (or (zerop (logand 2 mode)) (aset str 8 ?w))
939 (or (zerop (logand 1 mode)) (aset str 9 ?x))
940 (or (zerop (logand 1024 mode)) (aset str 3 (if (zerop (logand 64 mode))
942 (or (zerop (logand 2048 mode)) (aset str 6 (if (zerop (logand 8 mode))
946 ;;; ----------------------------------------------------------------------
947 ;;; See also convert-standard-filename which e.g. changes forward slashes
948 ;;; to backward slashes under win32.
950 (defun ti::file-name-for-correct-system (path system)
951 "Convert PATH to correct system: 'emacs, 'dos or 'cygwin.
955 PATH Path name. This must already be in expanded form.
956 Use Emacs function `expand-file-name' as needed.
958 SYSTEM 'cygwin => convert to cygwin path notation
959 'dos => convert to DOS notation.
960 'emacs => convert to notation which current Emacs uses.
961 If running Win32 native Emacs, convert to DOS.
962 If running Cygwin Emacs, convert to cygwin.
966 In native Win32 Emacs, the choice 'emacs work correctly only if package
967 cygwin-mount.el is active. The cygwin path are handled by it."
969 (when (string-match "~\\|\\.\\." path) ;; Need absolute path
970 (setq path (expand-file-name path)))
973 (setq path (w32-expand-file-name-for-emacs path))
974 (let ((func 'cygwin-mount-substitute-longest-mount-name))
975 (when (and (ti::emacs-type-win32-p)
977 (and (string-match "^/" path))
979 ;; Need to convert Cygwin => DOS path
980 (setq path (funcall func path)))))
982 (setq path (w32-expand-file-name-for-cygwin path)))
984 (if (string-match "^/cygdrive/" path)
985 (setq path (w32-cygwin-path-to-dos path))))))
990 ;;{{{ Version control, RCS delta files
992 ;;; ....................................................... &rcs-delta ...
993 ;;; In general, do not use these function, but use the top-level ones
994 ;;; that deal with filenames or buffers.
996 ;;; ----------------------------------------------------------------------
998 (defsubst ti::vc-rcs-delta-get-revisions (&optional buffer)
999 "Parse all revision numbers from delta file BUFFER.
1002 '(version version ..)"
1006 (set-buffer buffer))
1008 (while (re-search-forward "^[0-9.]+[0-9]+$" nil t)
1009 (push (match-string 0) list)))
1013 ;;; ----------------------------------------------------------------------
1015 (defun ti::vc-rcs-delta-get-file (file buffer)
1016 "Read delta FILE to temporary BUFFER.
1017 The delta file is truncated to header info only.
1022 BUFFER Existing buffer where to put delta.
1026 VC Generates error if file is not vc registered.
1030 buffer Possibly newly created buffer."
1031 (let* ((rcs-name (vc-name file))) ;; CVS returns entries.
1033 (error "Not an RCS file. %s" file))
1034 (with-current-buffer buffer
1036 (if (fboundp 'vc-insert-file) ;19.30
1037 (ti::funcall 'vc-insert-file rcs-name "^desc")
1038 (insert-file-contents rcs-name)
1039 (buffer-disable-undo)
1040 (set-buffer-modified-p nil)
1041 (auto-save-mode nil)
1042 (if (re-search-forward "^desc" nil t)
1043 (delete-region (point) (point-max))))))
1046 ;;; ----------------------------------------------------------------------
1048 (defun ti::vc-rcs-delta-lock-status (&optional user-name)
1049 "Return lock status by reading the delta buffer.
1050 If USER-NAME is non-nil return locks only for that user.
1053 ((USER . (VER VER ..)) (U . (V V)) ..)
1061 ;; jaalto:1.13; strict;
1063 (when (re-search-forward "^locks" nil t)
1065 (while (re-search-forward
1066 "^[ \t]+\\([^:]+\\):\\([^;\n\r]+\\)"
1068 (setq user (ti::remove-properties (match-string 1))
1069 ver (ti::remove-properties (match-string 2)))
1070 (if (or (null user-name)
1071 (ti::string-match-case (regexp-quote user-name) user))
1073 ((assoc user ret) ;already a user in list
1074 (ti::assoc-append-inside 'assoc user ret ver))
1077 (setq ret (list (cons user (list ver))))
1078 (push (cons user (list ver)) ret ))))))
1082 ;;; ----------------------------------------------------------------------
1084 (defsubst ti::vc-rcs-delta-lock-status-user (user)
1085 "Return list of locks for USER.
1086 This is toplevel function to `ti::vc-rcs-delta-lock-status'.
1087 Please use it directly if you want other users information too.
1088 If you only need *one* users information, use this function, because
1089 it hides the lock data structure.
1092 (VER VER ..) ,list of version strings.
1094 ;; this always parses the buffer.
1095 (cdr-safe (assoc user (ti::vc-rcs-delta-lock-status))))
1097 ;;; ----------------------------------------------------------------------
1099 (defsubst ti::vc-rcs-delta-highest-version ()
1100 "Return the highest version from delta buffer."
1104 (if (re-search-forward "head[ \t]+\\([.0-9]+\\)" nil t)
1108 ;;{{{ Version control, general
1110 ;;; ----------------------------------------------------------------------
1112 (defun ti::vc-dir-p (file-or-dir)
1113 "Check if FILE-OR-DIR looks like version controlled.
1114 Return type: 'rcs, 'cvs, 'monotone, 'subversion 'git' 'bzr' 'hg' or 'arch.
1115 Note, the return value is LIST."
1117 ((file-directory-p file-or-dir)
1119 ((or (file-name-directory file-or-dir)
1120 (let ((buffer (or (get-buffer file-or-dir)
1121 (get-file-buffer file-or-dir)
1122 (find-buffer-visiting file-or-dir))))
1124 (file-name-directory
1125 (buffer-file-name buffer))))))))
1126 (check '(("CVS/Entries" cvs)
1128 ;; #todo: Correct these
1135 (setq dir (file-name-as-directory dir))
1137 (multiple-value-bind (try type) elt
1138 (setq try (concat dir try))
1139 (if (or (file-exists-p try)
1140 (file-directory-p try))
1145 ;;{{{ Version control, string, RCS information
1146 ;;; ............................................................. &rcs ...
1147 ;;; Refer to GNU RCS ident(1) how to construct valid identifiers.
1149 ;;; ----------------------------------------------------------------------
1151 (defsubst ti::vc-rcs-read-val (str)
1152 "Cleans the RCS identifiers from the STR and return the value."
1153 (let* ((re ".*[$][^ \t]+: \\(.*\\) [$]"))
1154 (if (and (stringp str)
1155 (string-match re str))
1156 (match-string 1 str)
1159 ;;; ----------------------------------------------------------------------
1161 (defun ti::vc-rcs-look-id (str)
1162 "Return the RCS identifier in STR."
1163 (let* ((re ".*[$]\\([^ \t]+\\): .* [$]"))
1164 (if (string-match re str)
1165 (match-string 1 str)
1169 ;;{{{ Version control, CVS
1171 ;;; ----------------------------------------------------------------------
1173 (defsubst ti::vc-cvs-to-cvs-dir (file)
1174 "Return CVS directory for file."
1175 (concat (file-name-directory file) "CVS"))
1177 ;;; ----------------------------------------------------------------------
1179 (defsubst ti::vc-cvs-to-cvs-dir-p (file)
1180 "Check if there is CVS directory for file. Return CVS path if CVS exist."
1181 (let* ((path (ti::vc-cvs-to-cvs-dir file)))
1182 (when (file-directory-p path)
1185 ;;; ----------------------------------------------------------------------
1187 (defun ti::vc-cvs-to-cvs-file (file cvs-file)
1188 "Use FILE or directory and return CVS/CVS-FILE, like `Root'.
1189 If CVS-FILE does not exist, return nil."
1190 (let* ((path (ti::vc-cvs-to-cvs-dir file))
1191 (root (and path (concat path "/" cvs-file))))
1193 (file-exists-p root))
1196 ;;; ----------------------------------------------------------------------
1198 (defun ti::vc-cvs-to-cvs-file-content (file cvs-file)
1199 "Use FILE or directory name as base and return contents of CVS-FILE as string."
1200 (let* ((file (ti::vc-cvs-to-cvs-file file cvs-file)))
1203 (insert-file-contents file)
1206 ;;; ----------------------------------------------------------------------
1208 (defun ti::vc-cvs-file-exists-p (file)
1209 "Return cvs-entry if FILE is in VCS controlled.
1210 Look into CVS/Entries and return line from it if file was CVS controlled."
1211 (let* ((cvs-dir (ti::vc-cvs-to-cvs-dir-p file))
1214 (file-directory-p cvs-dir)
1215 (setq cvs-file (concat cvs-dir "/Entries"))
1216 (file-exists-p cvs-file))
1218 ;; CVS/Entries contain information on files in repository
1219 (ti::find-file-literally cvs-file (current-buffer))
1220 ;; /tinylib.el/1.1.1.1/Thu Dec 24 04:34:10 1998//
1221 (if (re-search-forward
1222 (concat "^/" (regexp-quote (file-name-nondirectory file)))
1224 (ti::read-current-line))))))
1226 ;;; ----------------------------------------------------------------------
1228 (defsubst ti::vc-cvs-entry-split (line)
1229 "Split cvs /Entries LINE into pieces.
1230 /add-log.el/1.1.1.2.2.4/Wed Jan 05 11:25:14 2000//Tb20_4
1233 (split-string line "/")))
1235 ;;; ----------------------------------------------------------------------
1237 (defsubst ti::vc-cvs-entry-type (line)
1238 "Return type 'dir or 'file for cvs /Entries LINE"
1241 ((string-match "^D/" line) 'dir)
1242 ((string-match "^/" line) 'file) )))
1244 ;;; ----------------------------------------------------------------------
1246 (defsubst ti::vc-cvs-entry-split-info (info what)
1247 "Request information on the CVS Entries line INFO.
1250 INFO list returned by `ti::vc-cvs-entry-split'
1251 WHAT list of returned values: 'file 'revision 'time 'rest."
1253 (dolist (type (ti::list-make what))
1255 ((eq type 'file) (nth 0 info))
1256 ((eq type 'revision) (nth 1 info))
1257 ((eq type 'time) (nth 2 info))
1258 ((eq type 'rest) (nth 4 info))
1259 ((error "Invalid WHAT arg %s" type)))
1265 ;;{{{ Version control, RCS
1267 ;;; ----------------------------------------------------------------------
1269 (defsubst ti::vc-rcs-file-p (file)
1270 "Return t if FILE STRING is in RCS controlled form.
1271 That is, if FILE has ,v at the end."
1272 (and (> (length file) 2)
1273 (string= (substring file -2) ",v")))
1275 ;;; ----------------------------------------------------------------------
1277 (defun ti::vc-rcs-make-filename (file &optional vc-subdir)
1278 "Constructs RCS controlled FILE name. VC-SUBDIR is by default RCS/.
1279 FILE --> PATH/vc-subdir/FILE,v"
1284 ((ti::vc-rcs-file-p file)
1287 (setq dir (or (file-name-nondirectory file) "./"))
1288 (setq fn (file-name-directory file))
1289 (setq ret (concat dir (or vc-subdir "RCS/") fn ",v"))))
1292 ;;; ----------------------------------------------------------------------
1294 (defsubst ti::vc-rcs-file-exists-p (file)
1295 "Return t if equivalent RCS FILE can be found.
1296 If the following condition is met, then such file exists:
1297 ~/dir1/dir2/file.cc --> ~/dir1/dir2/RCS/file.cc,v"
1298 (let* ((rcs (ti::vc-rcs-make-filename file)))
1299 (file-exists-p rcs)))
1301 ;;; ----------------------------------------------------------------------
1303 (defsubst ti::vc-rcs-normal-file (rcs-file)
1304 "Return normal file when version controlled RCS-FILE is given."
1305 (let* (( case-fold-search nil))
1306 (when (ti::vc-rcs-file-p rcs-file)
1307 (setq rcs-file (replace-regexp-in-string "RCS/" "" rcs-file))
1308 (setq rcs-file (replace-regexp-in-string ",v" "" rcs-file)))
1311 ;;; ----------------------------------------------------------------------
1313 (defun ti::vc-rcs-sort-same-level-list (list)
1314 "Sort RCS revision LIST, which are at same level.
1315 Ie. when only the last version number changes:
1316 1.1 1.2 1.3, or 1.2.1.1 1.2.1.3 1.2.1.10"
1324 ;; ... ... ... ... ... ... ... ... ... ... ... ... ... .. greatest ...
1325 (dolist (nbr list) ;find greatest. 1.xx
1326 (setq max (max (length nbr) max)))
1327 ;; ... ... ... ... ... ... ... ... ... ... ... ... ... ... .. padd ...
1329 (dolist (elt ptr) ;padd 1.1 --> 1.01
1330 (setq len (length elt))
1331 (unless (eq len max)
1332 (setq padd (make-string (- max len) ?0))
1333 (if (not (string-match "[0-9]+$" elt))
1334 (setq elt nil) ;Invalid entry
1335 (setq str (match-string 0 elt) )
1336 (setq elt (ti::replace-match 0 (concat padd str) elt))))
1338 (push elt new-list)))
1339 ;; ... ... ... ... ... ... ... ... ... ... ... ... ... ... .. sort ...
1340 (setq new-list (sort new-list 'string<))
1341 ;; Check if the values are doubled, and only then fix the list.
1342 ;; Hmm, if this happens, then the error is not in the 'sort'
1343 ;; but somewhere else.
1345 ;;; ((and new-list (string= (nth 0 new-list)
1346 ;;; (nth 1 new-list)))
1347 ;;; (setq new-list (ti::list-remove-successive new-list 'string=))
1349 ;; ... ... ... ... ... ... ... ... ... ... ... ... ... remove padd ...
1351 (dolist (elt ptr) ;fix 1.01 > 1.1
1352 (when (string-match "\\.\\(0+\\)[1-9][0-9]*$" elt)
1353 (setq elt (ti::replace-match 1 "" elt)))
1357 ;;; ----------------------------------------------------------------------
1359 (defun ti::vc-rcs-files-in-dir (&optional dir re)
1360 "Return all RCS controlled files in directory DIR.
1361 It doesn't matter if the directory points to RCS itself or
1362 one level up. Thus the two DIR parameters are identical:
1364 /mydir/ takes longer to execute.
1367 The DIR parameter can hold filename, but only the directory portion
1368 is used. If no directory portion exists \"./\" will be used.
1370 Filenames returned do not have any \",v\" extensions or directories.
1372 Optional RE tells to return files matching RE only.
1375 list (file file ..)"
1376 (let* ((re (or re ".")) ;default to match all
1382 (if (null (file-directory-p dir))
1383 (error "Not a directory"))
1384 (setq d (or (and dir
1385 (or (file-name-directory (expand-file-name dir))
1389 ((ti::string-match-case "RCS/?" d)
1390 (setq list (directory-files d nil re))
1392 (set fn (replace-regexp-in-string ",v$" "" elt))
1395 (setq list (directory-files d nil re))
1397 (setq fnn (concat d fn)) ;with directory
1398 (if (and (not (file-directory-p fnn))
1399 (ti::vc-rcs-file-exists-p (concat d fn)))
1403 ;;; ----------------------------------------------------------------------
1404 ;;; - The vc. does not return the _version_ latest.
1405 ;;; See vc-hook/ vc-fetch-properties
1407 (defsubst ti::vc-rcs-head-version (file)
1408 "Get latest version, the head, for FILE.
1409 No errors generates although file is not in RCS tree.
1412 string version string
1413 nil not an rcs file"
1415 ;; May not be RCS file
1416 (ignore-errors (ti::vc-rcs-delta-get-file file (current-buffer)))
1417 (ti::vc-rcs-delta-highest-version)))
1419 ;;; ----------------------------------------------------------------------
1421 (defun ti::vc-rcs-guess-buffer-version (file &optional user)
1422 "Try to guess right version number for buffer visiting FILE.
1423 If file is locked, look at delta log to find out version, otherwise call
1424 `ti::vc-rcs-buffer-version' and consult vc if needed.
1429 USER rcs user name, defaults to (user-login-name)
1435 (let* ((user (or user (user-login-name)))
1438 (when (not buffer-read-only) ;It's Checked Out
1439 ;; Never trust the ID string in the buffer, always look
1440 ;; at delta file --> this may be checked out with -k and
1441 ;; then RCS strings are not updated.
1443 (ti::vc-rcs-delta-get-file file (current-buffer))
1444 ;; We're interested in current user's locks only
1445 (setq list (ti::vc-rcs-delta-lock-status user))))
1448 (eq 1 (length list))
1449 (setq list (cdr (car list)))
1450 (eq 1 (length list)))
1451 ;; Okay, only 1 version locked, then we're safe
1452 (setq ver (car list)))
1456 (set-buffer (get-file-buffer file))
1457 (ti::vc-rcs-buffer-version))
1458 (vc-file-getprop file 'vc-workfile-version)
1462 ;;; ----------------------------------------------------------------------
1464 (defun ti::vc-rcs-buffer-version (&optional buffer)
1465 "Return version number for optional BUFFER.
1466 Supposes that RCS string 'Revision' 'Id' or 'Log' exist.
1467 If they do not exist, then see if VC is loaded and look at the modeline.
1469 Please use `ti::vc-rcs-guess-buffer-version' and not this function."
1474 (set-buffer buffer))
1478 ((setq tmp (ti::vc-rcs-str-find "Revision"))
1479 (setq rev (ti::vc-rcs-read-val tmp)))
1480 ((ti::vc-rcs-str-find "Log" )
1482 (setq rev (ti::buffer-match ".*Revision +\\([0-9.]+\\)" 1)))
1483 ((setq tmp (ti::vc-rcs-str-find "Id" 'value))
1484 (setq rev (nth 1 (split-string tmp " ")))))))
1485 ;; See if VC is installed and ask from it then.
1487 (fboundp 'vc-mode-line))
1488 (setq rev (ti::string-match "[^.0-9]*\\([.0-9]+\\)" 1
1489 (or (symbol-value 'vc-mode) ""))))
1492 ;;; ----------------------------------------------------------------------
1494 (defsubst ti::vc-rcs-rlog-get-revisions ()
1495 "REad all revision numbers from rcs rlog buffer.
1496 The line searched looks like:
1498 revision 1.10 locked by: loginName;
1503 list revision numbers
1505 (let* ((re "^revision[ \t]+\\([.0-9]+\\)$")
1510 (while (re-search-forward re nil t)
1511 (if (setq ver (match-string 1))
1515 ;;; ----------------------------------------------------------------------
1517 (defsubst ti::vc-rcs-all-versions (file)
1518 "Return string list of all version numbers for FILE."
1520 (ti::vc-rcs-delta-get-file file (current-buffer))
1521 (ti::vc-rcs-delta-get-revisions)))
1523 ;;; ----------------------------------------------------------------------
1524 ;;; For big files this is real slow, since building up lists and
1525 ;;; sort the revisions is hard
1527 (defun ti::vc-rcs-previous-version (version v-list)
1528 "Return previous version for FILE.
1529 Do not call this function Often, since it may be quite time consuming.
1533 VERSION ,lever as string, e.g. \"1.5\"
1534 V-LIST ,all version numbers for file, order not significant.
1538 RCS tree previous version
1550 (setq branch-list (ti::vc-rcs-get-all-branches version v-list))
1553 ;; record the error to *Message* buffer
1554 (message "Tinylib: [rcs] This level does not have version? %s" version))
1555 ;; after 1.1.1.1 we go up one level, to 1.1
1556 ((setq ret (ti::string-match"\\([.0-9]*\\).1.1$" 1 version)))
1558 (setq list branch-list tmp nil)
1560 (if (not (string= elt version))
1566 ;;; ----------------------------------------------------------------------
1568 (defun ti::vc-rcs-get-all-branches (rev rev-list)
1569 "Return sorted braches, lowest first, at same revion level.
1573 REV version number string
1574 REV-LIST list of version numbver string
1578 if version is 1.2, return all 1.x branches
1579 if version is 1.2.1.1, return all 1.2.1.x branches"
1582 (if (null val) ;Quiet XEmacs 19.14 ByteComp
1583 (setq val (ti::string-match ".*\\." 0 rev))) ;remove last number
1586 (ti::list-find rev-list
1588 ;; - The count thing just makes sure we get
1589 ;; 1.1 and 1.2 , not 1.1.1.1
1590 ;; - match makes sure that the start of the string is same
1591 ;; 1. --> 1.2 1.3 1.4
1594 (and (eq (count-char-in-string ?. arg)
1595 (count-char-in-string ?. elt))
1596 (string-match val elt))))
1599 ;; Simple (setq list (sort list 'string<)) won't do the job,
1600 ;; since it claims 1.10 is before 1.9
1606 (setq list (ti::vc-rcs-sort-same-level-list list)))
1610 ;;{{{ Version control, buffer's RCS strings, other
1612 ;;; ----------------------------------------------------------------------
1614 (defun ti::vc-version-string-p (version)
1615 "Test if VERSION looks like version number N.N, N.N.N etc."
1616 (and (stringp version)
1617 (string-match "^[0-9]+\\.[0-9]+\\(\\.[0-9]+\\)*$" version)))
1619 ;;; ----------------------------------------------------------------------
1621 (defun ti::vc-version-simple-p (version)
1622 "test if VERSION is simple N.N; N.N.N would be complex."
1623 (and (stringp version)
1624 (eq 1 (count-char-in-string ?. version))))
1626 ;;; ----------------------------------------------------------------------
1628 (defun ti::vc-version-lessp (a b &optional zero-treat)
1629 "Return t if A is later version than B.
1630 This function can only check only three levels; up till: NN.NN.NN.
1640 A Version string one
1641 B Version string two
1642 ZERO-TREAT If non-nil, consider version numbers starting with 0.NN
1643 never than 2.1. In this case it is assumed
1644 that zero based versions are latest development releases."
1645 (flet ((version (str regexp)
1646 (if (string-match regexp str)
1647 (string-to-number (match-string 1 str))
1649 (let* ((a1 (version a "^\\([0-9]+\\)"))
1650 (a2 (version a "^[0-9]+\\.\\([0-9]+\\)"))
1651 (a3 (version a "^[0-9]+\\.[0-9]+\\.\\([0-9]+\\)"))
1652 (b1 (version b "^\\([0-9]+\\)"))
1653 (b2 (version b "^[0-9]+\\.\\([0-9]+\\)"))
1654 (b3 (version b "^[0-9]+\\.[0-9]+\\.\\([0-9]+\\)")))
1665 ;;; ----------------------------------------------------------------------
1667 (defun ti::vc-rcs-str-find (str &optional mode)
1668 "Try to find rcs string STR starting from the point forward.
1672 By default whole string is returned.
1673 If MODE is non-nil, the value of rcs identifier is returned."
1675 ;; RCS keywords are like this:
1679 (let* ((re (concat "[$]" str ":[^$]+[$]"))
1681 (if (null (re-search-forward re nil t))
1683 (setq ret (match-string 0))
1686 (ti::vc-rcs-read-val ret)))))
1688 ;;; ----------------------------------------------------------------------
1689 ;;; - In fact this should be macro, defsubst
1691 (defsubst ti::vc-rcs-str-find-buffer (str &optional mode)
1692 "Try to find rcs string STR starting from `point-min'.
1695 By default whole string is returned.
1696 If MODE is non-nil, the value of rcs identifier is returned.
1700 (ti::vc-rcs-str-find-buffer \"Id\" 'value)"
1704 (ti::vc-rcs-str-find str mode))))
1710 ;;; ............................................................ &date ...
1712 ;;; ----------------------------------------------------------------------
1714 (defun ti::date-standard-rfc-regexp (&optional type time)
1715 "Return RFC date matching regexp: Feb 9 16:50:01.
1718 TYPE \"mon\" .. \"mon-date-hh-mm-ss\" What elements to inlcude.
1719 TIME if not set, use `current-time'.
1721 Note it makes no sense to request \"mon-mm\", because the return
1722 value si cumulated. Do not leave out directived from the middle, but
1731 (setq time (current-time)))
1732 (let* ((mon (format-time-string "%b" time))
1733 (dd (ti::string-trim-blanks
1734 (format-time-string "%e" time)))
1735 (hh (format-time-string "%H" time))
1736 (mm (format-time-string "%M" time))
1737 (ss (format-time-string "%S" time))
1740 ((not (stringp type))
1743 (when (string-match "mon" type)
1744 (setq ret (concat (or ret "") mon)))
1745 (when (string-match "date" type)
1746 (setq ret (concat (or ret) " +" dd)))
1747 (when (string-match "hh" type)
1748 (setq ret (concat (or ret) " +" hh)))
1749 (when (string-match "mm" type)
1750 (setq ret (concat (or ret) ":" mm)))
1751 (when (string-match "ss" type)
1752 (setq ret (concat (or ret) ":" ss)))))
1755 ;;; ----------------------------------------------------------------------
1756 ;;; #defalias (defalias 'time-now 'ti::date-standard-date)
1759 (when (fboundp 'format-time-string) ;19.29+
1760 (defun ti::date-standard-date (&optional type time)
1761 "Return time RFC 'Nov 07 1995 20:49' or in SHORT
1763 TYPE return YYYY-MM-DD instead (ISO 8601).
1764 if 'minutes, return YYYY-MM-DD HH:MM.
1765 TIME-STRING User supplied string in format `current-time-string'."
1768 (format-time-string "%Y-%m-%d %H:%M" (or time (current-time))))
1770 (format-time-string "%Y-%m-%d" (or time (current-time))))
1772 (format-time-string "%b %d %Y %H:%M"
1773 (or time (current-time)))))))
1776 (unless (fboundp 'format-time-string)
1777 (defun ti::date-standard-date (&optional type time)
1778 "Return Time 'Nov 10th 1995 20:49'.
1780 TYPE return YYYY-MM-DD ISO 8601.
1781 if 'minutes, return YYYY-MM-DD HH:MM.
1782 TIME User supplied time in format `current-time'."
1784 (let* ((list (ti::date-time-elements nil (current-time-string
1785 (or time (current-time)))))
1789 (setq nbr (cdr (assoc (nth 5 list) (ti::month-mm-alist))))
1794 (int-to-string (nth 0 list))
1795 (if (not (eq type 'minutes))
1797 (concat " " (nth 3 list)))))
1799 (concat (nth 5 list) " "
1800 (int-to-string (nth 0 list))
1801 (ti::string-nth-from-number (nth 0 list)) " "
1805 ;;; ----------------------------------------------------------------------
1807 (defun ti::date-month-to-number (arg &optional mode)
1808 "Return month number for string or vice versa.
1812 Accepts Jan or January with any case --> Return nbr or nil
1814 When MODE is non-nil
1816 Accepts nbr or str-nbr --> return str or nil"
1819 '(("jan" . 1) ("feb" . 2) ("mar" . 3) ("apr" . 4)
1820 ("may" . 5) ("jun" . 6) ("jul" . 7) ("aug" . 8)
1821 ("sep" . 9) ("oct" . 10) ("nov" . 11) ("dec" . 12)))
1829 (setq len (length arg))
1830 (if (> len 3) (setq arg (substring str 0 3))) ; cut to 3 chars
1831 (setq idx (downcase arg))
1832 (if (setq el (assoc idx alist))
1833 (setq ret (cdr el))))
1835 (if (stringp arg) (setq arg (string-to-int arg)))
1837 (if (setq el (rassq idx alist))
1838 (setq ret (car el)))))
1841 ;;; ----------------------------------------------------------------------
1843 (defun ti::date-time-difference (a b &optional float)
1844 "Calculate difference beween times A and B optionally in FLOAT seconds.
1845 The input must be in form of '(current-time)'
1846 The returned value is difference in seconds.
1847 E.g. if you want to calculate days; you'd do
1848 \(/ (ti::date-time-difference a b) 86400) ;; 60sec * 60min * 24h"
1851 (multiple-value-bind (s0 s1 s2) a
1852 (setq a (+ (* (float (ash 1 16)) s0)
1853 (float s1) (* 0.0000001 s2))))
1854 (multiple-value-bind (s0 s1 s2) b
1855 (setq b (+ (* (float (ash 1 16)) s0)
1856 (float s1) (* 0.0000001 s2))))
1858 (let ((hi (- (car a) (car b)))
1859 (lo (- (car (cdr a)) (car (cdr b)))))
1860 (+ (lsh hi 16) lo))))
1862 ;;; ----------------------------------------------------------------------
1864 (defun ti::date-time-diff-days (std1 std2)
1865 "Return approximation of time difference in days.
1866 STD1 and STD2 are two standard times in short format YYYY-MM-DD.
1867 In calculation each month is supposed to have 30 days and a year 356 days."
1868 (let ((re "\\([0-9][0-9][0-9][0-9]\\)-\\([0-9]+\\)-\\([0-9]+\\)")
1872 (string-match re std1)
1873 (setq y1 (string-to-int (match-string 1 std1))
1874 m1 (string-to-int (match-string 2 std1))
1875 d1 (string-to-int (match-string 3 std1)))
1876 (string-match re std2)
1877 (setq y2 (string-to-int (match-string 1 std2))
1878 m2 (string-to-int (match-string 2 std2))
1879 d2 (string-to-int (match-string 3 std2)))
1880 (if (>= (- d2 d1) 0) ;day2 is smaller
1881 (setq ret (- d2 d1))
1882 (setq ret (- (+ 30 d2) d1))
1884 (incf ret (* 30 (- m2 m1)))
1885 (incf ret (* 356 (- y2 y1)))
1888 ;;; ----------------------------------------------------------------------
1889 ;;; Try this: (ti::date-parse-date "Wed, 21 Jul 93 09:26:30 EST")
1891 (defun ti::date-parse-date (str)
1892 "Try to parse date field.
1896 list ,(dd mm yy tt wd m yy tz)
1897 \"\" in fields which weren't identified.
1900 0 YYYY year 4 numbers
1904 4 wd week day string e.g. \"Mon\"
1905 5 m month string e.g. \"Jun\"
1906 7 tz time zone e.g. [+-]nnnn, where n = number"
1915 (rAaa "\\([A-Z][a-z][a-z]\\)")
1916 (rd "\\([0-9][0-9]?\\)") ;; typical day nbr
1917 (rd4 "\\([0-9][0-9][0-9][0-9]\\)") ;; typical year nbr (regexp day)
1918 (rt "\\([0-9]+:[0-9:]+\\)") ;; time
1920 (rz "\\([+-][0-9]+\\|[A-Z][A-Z][A-Z]+[^ \t\n]*\\)?") ;; timezone
1922 (concat rd4 " +" rt)) ;; 1994 08:52:25
1924 (concat rd " +" rt)) ;; 94 08:52:25
1926 (concat rAaa ",? +" rd " +" rAaa)) ;; weekday: Mon, 24 Oct
1928 (concat rd ",? +" rAaa " +")) ;; 24 Oct
1929 ;; (current-time-string) Wed Oct 14 22:21:05 1987
1931 (concat re-wd " +" re-yyyy " *" rz )) ;; Mon, 24 Oct 1994 08:52:25 +0200
1933 (concat re-wd " +" re-yy " *" rz )) ;; Mon, 24 Oct 94 08:52:25 +0200
1935 (concat re-dd re-yyyy " *" rz)) ; 24 Oct 1994 00:28:04 GMT
1937 ;; 24 Oct 94 00:28:04 GMT
1938 (concat re-dd re-yy " *" rz)))
1939 ;; Tue, 1 Nov 1994 8:52:36 +0300 (EET)
1941 ((or (string-match re-wd-4y str)
1942 (string-match re-wd-2y str))
1943 (setq wd (match-string 1 str)
1944 dd (match-string 2 str)
1945 m (match-string 3 str)
1946 yyyy (match-string 4 str)
1947 tt (match-string 5 str)
1948 tz (match-string 6 str)))
1949 ;; 24 Oct 1994 00:28:04 GMT
1950 ((or (string-match re-dd-yyyy str)
1951 (string-match re-dd-yy str))
1952 (setq dd (match-string 1 str)
1953 m (match-string 2 str)
1954 yyyy (match-string 3 str)
1955 tt (match-string 4 str)
1956 tz (match-string 5 str))))
1957 (when (and yyyy (eq (length yyyy) 2))
1959 (if (string-match "^[789]" yyyy) "19" "20")
1962 (setq mm (format "%02d" (ti::date-month-to-number m))))
1964 (setq dd (format "%02d" (string-to-int dd))))
1965 (list yyyy mm dd tt wd m tz)))
1968 ;;{{{ string(s), chars
1970 ;;; ########################################################## &string ###
1972 ;;; ----------------------------------------------------------------------
1973 ;;; #defalias (defalias 'string-repeat 'ti::string-repeat)
1975 (defun ti::string-repeat (count char-or-string)
1976 "Repeat COUNT times CHAR-OR-STRING."
1979 (if (characterp char-or-string) ;; XEmacs compatibility needed
1980 (setq char-or-string (char-to-string char-or-string)))
1982 (if (integerp char-or-string)
1983 (setq ret (make-string count char-or-string))
1986 (setq ret (concat ret char-or-string))
1990 ;;; ----------------------------------------------------------------------
1992 (defun ti::string-syntax-info (char &optional verb)
1993 "Return brief syntax definition string for CHAR. VERB."
1994 (interactive "cShow syntax of char: ")
1995 (let* ((syntax (char-syntax char ))
1996 (elt (assq syntax ti::var-syntax-info))
1997 (verb (or verb (interactive-p)))
2001 (char-to-string syntax)
2003 (if elt (nth 1 elt) "")))
2008 ;;; ----------------------------------------------------------------------
2010 (defun ti::string-syntax-kill-double-quote ()
2011 "Kill double quote string syntax class for current buffer.
2012 This is usually useful when you turn on `font-lock' in current
2013 buffer where there won't be equal amount of \" and ' pairs.
2014 Your highlighting will then work as expected after syntaxes are killed."
2016 (let ((table (make-syntax-table)))
2017 (modify-syntax-entry ?\" "_" table)
2018 (set-syntax-table table)))
2020 ;;; ----------------------------------------------------------------------
2022 (defun ti::string-tabify (string &optional mode)
2023 "Tabify STRING, or if MODE is non-nil, untabify."
2024 (let* ((indent-tabs-mode t)) ;makes sure tabs are used.
2028 (tabify (point-min) (point-max))
2029 (untabify (point-min) (point-max)))
2032 ;;; ----------------------------------------------------------------------
2033 ;;; - This is slightly different than the next one. Use the one you need.
2035 (defun ti::string-match-string-subs (level-list &optional string terminate)
2036 "Return matcg list according to subexpression list LEVEL-LIST.
2038 Supposes that you have already done the matching. If STRING is not
2039 given, the buffer will be used for reading.
2041 If optional TERMINATE is non-nil, terminates if any of the matches return
2042 nil. In this case the return list will be empty signifying that all matches
2046 level-list list e.g. '(1 0 2)
2047 string str e.g. \"testThis\"
2050 ( \"str\" nil \"str\" .. )
2054 (dolist (level level-list)
2055 (setq str (match-string level string))
2056 (if (and terminate (null str))
2058 (setq ret nil) ;that's it then...
2063 ;;; ----------------------------------------------------------------------
2065 (defun ti::string-match-string-list (match-list level-list string &optional terminate)
2066 "Return match list list according to subexpressions.
2070 MATCH-LIST list e.g. '(\"\\(re1\\)\" \"re2\" \"\\(cash\\(re3\\)\\)\"
2071 LEVEL-LIST list e.g. '(1 0 2)
2072 STRING str e.g. \"re1 re2 cashre3\"
2073 TERMINATE any e.g. nil, 'terminate
2075 Supposes that you have already done the matching.
2077 If the match wasn't found in current level, it assign nil to the
2078 corresponding position in return list
2080 If optional TERMINATE is non-nil, terminates if any of the matches return
2081 nil. In this case the return list will be empty signifying that all matches
2085 ( \"str\" nil \"str\" .. )
2089 (if (not (eq (length match-list)
2090 (length level-list)))
2091 (error "List length mismatch."))
2093 (setq str (ti::string-match (car match-list) (car level-list) string))
2094 (if (and terminate (null str))
2095 (setq ret nil level-list nil) ;that's it then...
2096 (ti::nconc ret str))
2101 ;;; ----------------------------------------------------------------------
2103 (defun ti::string-case-replace (model str &optional symmetry rest-case)
2104 "Use MODEL and change case of characters in STR.
2105 Preserve case if SYMMETRY is non-nil.
2107 E.g. If your input is:
2112 and the symmetry is non-nil, you get
2116 If the model is too short the variable REST-CASE instructs what to do
2118 nil --> the rest of the STR will be added \"as is\"
2119 'follow --> the rest of the STR are in the same case as last
2121 'lower --> insert rest as lowercase
2122 'upper --> insert rest as uppercase"
2125 case-fold-search ;case is important
2133 (setq len (min (length str) (length model))
2135 ;; ............................................ MODEL characters ...
2137 (setq ch-model (char-to-string (aref model i))
2138 ch (char-to-string (aref str i)))
2140 ((string-match "[a-z]" ch-model)
2141 (setq ch (downcase ch) last 'downcase))
2142 ((string-match "[A-Z]" ch-model)
2143 (setq ch (upcase ch) last 'upcase))
2145 ;; MODEL has punctuation, choose previous case
2146 (if (eq last 'upcase)
2147 (setq ch (upcase ch))
2148 (setq ch (downcase ch)))))
2149 (setq ret (concat ret ch))
2151 ;; ............................................. REST characters ...
2152 ;; if MODEL is too short, then determine what to do to the rest
2153 ;; of the characters theat are left.
2154 (when (< (length model) (length str)) ;Need to guess REST model?
2155 (setq part (substring str len))
2157 ((eq rest-case 'follow)
2158 (setq ch (char-to-string (aref model (1- len)))) ;read last char
2160 ((string-match "[a-z]" ch)
2161 (setq part (downcase part)))
2162 ((string-match "[A-Z]" ch)
2163 (setq part (upcase part)))
2165 ;; kast char was punctuation, choose last type
2166 (if (eq last 'upcase)
2167 (setq part (upcase part))
2168 (setq part (downcase part))))))
2169 ((equal rest-case 'upper)
2170 (setq part (upcase part)))
2171 ((equal rest-case 'lower)
2172 (setq part (downcase part)))))
2173 (setq ret (concat ret part))
2176 ;;; ----------------------------------------------------------------------
2178 (defun ti::string-index (str char &optional reverse)
2179 "Check STR and first CHAR position 0..nbr.
2180 If REVERSE is non-nil, start searching at the end of string."
2181 (let ((len (length str))
2185 (while (and (>= (decf len) 0)
2186 (/= (aref str len) char))) ;check character in string
2191 (while (and (< (incf i) len)
2192 (/= (aref str i) char)))
2197 ;;; ----------------------------------------------------------------------
2199 (defun ti::string-index-substring (str char &optional include right seek-end)
2200 "Return left hand substring from STR maching CHAR.
2204 INCLUDE The CHAR itself is included too.
2205 RIGHT Return right hand portion.
2206 SEEK-END Search from the end.
2210 ;; To get only the file part, you'd say
2212 (setq string \"user@site:~/bin/myfile\")
2213 (ti::string-index-substring string ?: nil 'right)
2215 ;; To get last item, separated by |
2217 (setq string \"aa|bb|cc|dd\")
2218 (ti::string-index-substring string ?| nil 'right 'seek-end)
2223 char character to look in string
2224 include flag, should char be included too?
2225 right return right side of string
2226 seek-end start looking the position from the end instead
2231 nil no ch found, or impossible condition. Like if input STR is \":\"
2232 and don't want to include ?: character."
2236 ;; common mistakes, prevent it immediately, because
2237 ;; looking the cause in debuffer may be a bit hairy, due to
2238 ;; breakout only in ti::string-index
2240 (if (not (and str char))
2241 (error "parameter error %s %s" str char))
2242 (if (null (setq idx (ti::string-index str char seek-end)))
2246 (setq ret (substring str
2251 ;;; (ti::d! str include idx)
2252 (setq ret (substring str
2254 (if include ;; the second parameter
2257 (if (ti::nil-p ret) ;do not return empty strings
2261 ;;; ----------------------------------------------------------------------
2263 (defun ti::string-replace-one-space (str)
2264 "Convers all spaces/tabs in STR into one space."
2265 ;; #todo: Would using a temporary buffer + untabify + replace-regexps
2270 (while (and (> (length str) 0)
2271 (string-match "[ \t]+\\|$" str))
2272 (setq beg (match-beginning 0) end (match-end 0))
2273 ;; Take only 1 space (1+ ..
2275 ;; no more spaces ? , the "$" matched ...
2276 (if (eq beg (length str))
2278 ;; is the rest of it spaces ?
2279 (if (string-match "[ \t]+$" str) nil
2280 (setq out (concat out str)))
2281 (setq str "")) ;found empty space
2282 (setq out (concat out (substring str 0 (1+ beg))))
2283 (setq str (substring str end))))
2286 ;;; ----------------------------------------------------------------------
2287 ;;; 17 Aug 1995, gnu.emacs.help, kevinr@ihs.com (Kevin Rodgers)
2288 ;;; - Slightly modified by jaalto
2290 (defun ti::string-listify (string &optional sep)
2291 "Look STRING and search SEP [whitespace] and return list of substrings."
2293 (sep (or sep "[^ \f\t\n\r\v]+"))
2295 (while (string-match sep string start)
2297 (cons (substring string (match-beginning 0) (match-end 0))
2299 (setq start (match-end 0)))
2303 ;;{{{ buffer: line, information, dired
2305 ;;; ........................................................ &ange-ftp ...
2307 ;;; ----------------------------------------------------------------------
2309 (defun ti::dired-buffer (dir)
2310 "Return dired buffer for DIR if any."
2311 (setq dir (file-name-as-directory dir)) ;; Dired uses trailing slash
2312 (dolist (buffer (buffer-list))
2313 (when (with-current-buffer buffer
2314 (and (eq major-mode 'dired-mode)
2315 (string= dired-directory dir)))
2318 ;;; ----------------------------------------------------------------------
2320 (defsubst ti::buffer-get-ange-buffer-list (&optional regexp)
2321 "Return list of ange-ftp buffers matching optional REGEXP."
2322 (ti::dolist-buffer-list
2323 (and (string-match "internal.*ange" (symbol-name major-mode))
2324 (string-match (or regexp "^[*]ftp") (buffer-name)))
2327 ;;; ----------------------------------------------------------------------
2329 (defun ti::buffer-find-ange-buffer (user host)
2330 "Find ange ftp buffer with login USER running under HOST.
2335 (car-safe ;may be nil list
2336 (ti::buffer-get-ange-buffer-list
2337 (concat "^[*]ftp +" user "@" host "[*]"))))
2339 ;;; ----------------------------------------------------------------------
2341 (defun ti::buffer-find-ange-to-dired-buffer ()
2342 "Find associated dired buffer for current ange-ftp buffer.
2346 list list of possible buffers
2348 (let* ( ;; Check that we're in ange buffer "*ftp ..."
2349 (name (ti::string-match "^[*]ftp +\\(.*\\)[*]" 1 (buffer-name))))
2351 (ti::dolist-buffer-list
2352 (and (eq major-mode 'dired-mode)
2354 name (or (symbol-value 'dired-directory) "")))))))
2356 ;;; ........................................................ &uuencode ...
2358 ;;; ----------------------------------------------------------------------
2360 (defun ti::buffer-uu-area (&optional data-buffer buffer)
2361 "Find uuencoded region forward.
2365 DATA-BUFFER Where to look, defaults to `current-buffer'.
2366 BUFFER If non-nil, put uuencode data here.
2370 (beg . end) list, the uu data area
2371 nil no uu after point found"
2372 (let* ((case-fold-search nil) ;must use case sensitive
2373 (beg-re "begin[ \t]+[0-9]+[ \t]+.")
2374 (end-re "end[ \t]*$")
2379 (set-buffer (or data-buffer (current-buffer)))
2380 (and (re-search-forward beg-re nil t)
2381 (setq bol (line-beginning-position))
2382 (setq beg (match-beginning 0))
2383 (re-search-forward end-re nil t)
2384 (setq end (line-end-position))))
2385 (when (and beg end buffer)
2386 ;; First get the data
2387 (with-current-buffer buffer
2389 (insert-buffer-substring data-buffer bol end)
2390 ;; Remove possible leadings so that you can extract NEWS
2391 ;; citated UUdata too
2393 ;; > begin 0 cobol.el.gz
2394 ;; > M'XL("!?:;S```V-O8F]L+F5L`*P\:W/;1I*?Q;H?,4'MK@A%8"0GL9PH&Z\B
2395 (if (< (- beg bol) 1) ;no leading characters.
2397 (setq leading (concat "^" (make-string (- beg bol) ?.)))
2399 (ti::buffer-replace-regexp leading 0 ""))
2405 ;;; ----------------------------------------------------------------------
2407 (defun ti::buffer-uu-line-p (&optional string)
2408 "Determines if current line is UUencoded. Optionally check STRING.
2409 The line is considered as an uu line if it has no lowercase chars and has
2410 length more than 50 chars. Any leading spaces and tabs are skipped to find
2411 the UU start [applies to buffer reading only].
2413 Return length of line if it's UU, nil if not."
2415 (let* ((case-fold-search nil) ;case is important
2421 ((setq line (or string (ti::buffer-read-if-solid)))
2422 (setq len (length line))
2423 (if (and (not (string-match "[a-z]" line)) ;--> not UU line
2424 (> len at-least)) ;must be longer than xx chars
2428 ;;; ----------------------------------------------------------------------
2430 (defun ti::buffer-area-bounds (beg end)
2431 "Search area bounds delimited by _strings_ BEG and END.
2432 First searches backward, them forward.
2435 (beg-point . end-point)
2440 (search-backward beg)
2442 (search-forward end)
2444 (if (< (point) pp) (cons p pp) nil))
2450 ;;; ########################################################## &Buffer ###
2452 ;;{{{ buffer: reading lines, chars
2454 ;;; ----------------------------------------------------------------------
2456 (defun ti::buffer-parse-grep-line ()
2457 "Parse grep(1) formatted line. FILE:LINE:<content>.
2459 '(file line content)."
2466 ((looking-at "^[ \t]*\\([^:\r\n]+\\):\\([0-9]+\\):\\(.*\\)")
2468 (setq file (match-string 1)
2469 line (match-string 2)
2470 rest (match-string 3)))
2471 ((looking-at "^[ \t]*\\([a-zA-Z]:[^:\r\n]+\\):\\([0-9]+\\):\\(.*\\)")
2472 ;; d:/home/path/file.txt
2473 (setq file (match-string 1)
2474 line (match-string 2)
2475 rest (match-string 3))))
2477 (if (string-match "^[0-9]+$" line)
2478 (setq line (string-to-int line))
2481 (list file line rest)))))
2483 ;;; ----------------------------------------------------------------------
2485 (defun ti::buffer-parse-grep-line2 ()
2486 "Parse 'file nbr' format. Return '(file line)."
2490 (or (looking-at "^[ \t]*\\([^ \t\n:]+\\)[ \t]+\\([0-9]+\\)[ \t:]+")
2491 (looking-at (concat ".*line[ \t,\n]+\\([0-9]+\\)[ \t,\n]+"
2492 "file[ \t,\n]+\\([^ \t\n:)]+\\)")))
2495 (match-string 2)))))
2497 ;;; ----------------------------------------------------------------------
2499 (defun ti::buffer-parse-line-main ()
2500 "Find directory from the previous 'cd' command.
2501 Look current line first and if it has no directory part,
2504 Line formats recognized are:
2509 Or the format can be following, where tokens can span multiple lines
2511 line LINE, file LINE results
2515 You should probably call `ti::file-name-for-correct-system' to convert
2516 the filename to current Emacs and OS. (Like reading Cygwin paths under
2521 (file line) information
2523 (let* ( ;; (drive "\\([a-zA-Z]:\\)?")
2524 (cd-re1 ".*cd +\\(.*\\)")
2525 (cd-re2 "^cd +\\(.*\\)")
2531 ;; ................................................ grep-format ...
2532 (when (setq elt (or (ti::buffer-parse-grep-line)
2533 (ti::buffer-parse-grep-line2)))
2534 (setq file (nth 0 elt)
2536 ;; ..................................................... Paths ...
2537 (cond ;Unix, Dos paths
2539 (and (null (string-match (concat "^/\\|^[a-z]:[\\/]") file))
2540 (or (looking-at cd-re1)
2541 (re-search-backward cd-re2 nil t)))
2542 (setq path (match-string 1))))
2543 (buffer-file-name ;Another condition
2544 ;; If we loaded erorr log file from the same directory: try it
2546 ;; weblint file.html > file.err
2548 ;; --> then load file.err into emacs and start jumping to errors.
2549 (setq path (file-name-directory buffer-file-name))))
2550 ;; ./dir/file --> dir/file
2551 (if (and (stringp file)
2552 (string-match "^\\.[/\\]" file))
2553 (setq file (ti::replace-match 0 nil file)))
2554 (setq ret (list (if path
2555 (ti::file-make-path path file)
2561 ;;; ----------------------------------------------------------------------
2563 (defun ti::buffer-join-region (beg end)
2564 "Join the region BEG END into a single line."
2568 (while (> (point) beg)
2569 (delete-indentation)))
2570 (beginning-of-line))
2572 ;;; ----------------------------------------------------------------------
2574 (defun ti::buffer-read-if-solid ()
2575 "Read from current point all the non-whitespace characters.
2576 Ignores leading and trailing whitespace."
2577 (let* ((eol (line-end-position))
2581 (if (looking-at "[ \t]")
2582 (skip-syntax-forward " " eol))
2585 (skip-chars-forward "^ \t" eol)
2586 (if (eq (point) beg) ;not moved
2587 (end-of-line)) ;no trailing spaces
2588 (unless (eq (point) beg)
2589 (setq ret (buffer-substring beg (point))))))
2592 ;;; ----------------------------------------------------------------------
2594 (defun ti::buffer-read-whitespace (&optional point)
2595 "Gets whitespace following the point or optional at POINT.
2598 str whitespace string"
2599 (let* ((re-w "[ \t]+") ;whitespace
2600 mp ;maximum point, end of line
2607 (setq mp (line-end-position))
2608 (if (or (null (looking-at re-w)) ;not sitting on whitespace
2609 (null (re-search-forward re-w mp t)))
2611 (buffer-substring op (point))))))
2613 ;;; ----------------------------------------------------------------------
2615 (defun ti::buffer-read-paragraph ()
2616 "Read paragraph at point."
2619 (when (looking-at ".*[^ \t]")
2620 (backward-paragraph)
2621 (let* ((beg (point)))
2623 (buffer-substring beg (point))))))
2625 ;;; ----------------------------------------------------------------------
2626 ;;; - if you use outline or folding, please open the buffer first
2627 ;;; otw lines cannot be read correcly [the \n is missing if file
2628 ;;; has closed folds]
2630 (defun ti::buffer-read-line (&optional len skip)
2631 "Read whole line from buffer.
2634 LEN Only read LEN characters.
2635 If LEN is more than line has characters then return whole line.
2636 SKIP Ignores SKIP count characters from beginning of line.
2637 If there is not that many to skip, return full line."
2638 (let* ((line (ti::read-current-line))
2639 (len-full (length line)))
2642 ((and len (> len skip))
2643 (setq line (substring line skip)))
2644 ((eq len skip) (setq line ""))))
2645 (if (and len (< len len-full))
2646 (substring line 0 len)
2649 ;;; ----------------------------------------------------------------------
2651 (defun ti::buffer-grep-lines (re &optional beg end inc-prop)
2652 "Greps lines matching RE from buffer.
2656 BEG default is `point-min'
2657 END default is `point-max'
2658 INC-PROP do not remove properties while reading lines.
2662 nil or \(str str str ..\)"
2663 (let* ((beg (or beg (point-min))) ;point begin
2664 (end (or end (point-max))) ;point end
2669 (while (re-search-forward re end t)
2670 (setq line (ti::read-current-line))
2672 (setq line (ti::remove-properties line)))
2673 (ti::nconc list line)
2678 ;;{{{ buffer: matching, reading words, chars
2680 ;;; ....................................................... &b-reading ...
2682 ;;; ----------------------------------------------------------------------
2683 ;;; The bad thing is that it is impossible slow, so
2684 ;;; use it only when time is not critical (not in loops)
2686 (defun ti::buffer-looking-back-at (re)
2687 "Return t if text immediately before point match RE.
2688 This function modifies the match data that `match-beginning',
2689 `match-end' and `match-data' access; save and restore the match
2690 data if you want to preserve them.
2693 Use only if you need this badly. It's impossible slow."
2696 (while (and (null ret)
2697 (re-search-backward re nil t))
2698 (setq ret (eq (match-end 0) beg)))
2702 ;;; ----------------------------------------------------------------------
2704 (defun ti::buffer-read-char (&optional direction distance)
2705 "Read character towards the DIRECTION from current point.
2706 nil = forward, non-nil backward. DISTANCE 0/nil means reading from
2712 nil if the position is not within `point-min-marker' and
2713 `point-max-marker'."
2714 (let* ((beg (point-min-marker))
2715 (end (point-max-marker))
2716 (pos (or distance 0))
2718 (- (point) (1+ pos))
2720 (read (if (or (< dest beg) (> dest end))
2724 nil ;allowed to read ?
2725 (char-after dest))))
2727 ;;; ----------------------------------------------------------------------
2728 ;;; - You can define the "word" syntax here without changing syntax entries.
2729 ;;; - If you want to get word according to current mode's syntax table,
2730 ;;; use following instead
2732 ;;; (require 'thingatpt) ;19.29
2735 (defun ti::buffer-read-word (&optional charset strict)
2736 "Return word specified by optional CHARSET after point.
2737 If optional STRICT is non-nil, requires that point is sitting on
2738 CHARSET before continuing. If there is no CHARSET under point,
2739 search forward for word.
2743 Cannot read word that starts at beginning of buffer
2747 (let* ((charset (or charset "-a-zA-Z0-9_"))
2748 (not (concat "^" charset)))
2750 (if (or (null strict)
2751 (and strict (looking-at charset)))
2754 (skip-chars-forward not)
2755 (skip-chars-backward charset)
2758 (skip-chars-forward charset)
2761 ;;; ----------------------------------------------------------------------
2762 ;;; - This is totally different from the other word reading funcs,
2763 ;;; it gives you the word separated by spaces. For more finer control see,
2764 ;;; CHARSET in ti::buffer-read-word
2766 (defun ti::buffer-read-space-word ()
2767 "Return word separated by spaces or bol/eol.
2768 If sitting on space or tab, read next word forward. If sitting in the
2769 middle of word, find the word beginning until bol, and start reading from
2770 that point. Point is moved to the beginning of word.
2775 (let* ((bol (line-beginning-position))
2779 (equal (char-syntax (preceding-char)) ?\ ))
2780 ;; At the beginning of word, first char
2782 ((looking-at "[^ \t\n]")
2784 (skip-chars-backward "^ \t\n" bol)
2785 ;; (skip-syntax-backward " " bol)
2786 (if (eq p (point)) ;jump not done.
2787 (beginning-of-line))) ;text starts at bol
2788 ((looking-at "[ \t\n]")
2789 (skip-chars-forward " \t\n"))
2790 ((save-excursion ;is the line end of buffer
2791 (end-of-line) ;--> e.g. in minibuffer
2793 (beginning-of-line)))
2794 (ti::buffer-read-if-solid)))
2796 ;;; ----------------------------------------------------------------------
2798 (defun ti::buffer-read-syntax-word (syntax &optional mode)
2799 "Read block of characters from current point.
2800 Blocks are separated by SYNTAX Normally the block is read
2801 from current point forward.
2804 SYNTAX class like \"w\" for words.
2805 MODE 'back read backward
2806 'word read full word, skip syntax forward, then backward.
2811 nil current point does not contain SYNTAX class char."
2812 (let* ((beg (point))
2819 (skip-syntax-backward syntax)
2822 (skip-syntax-forward syntax) (setq end (point))
2823 (skip-syntax-backward syntax) (setq beg (point)))
2825 (skip-syntax-forward syntax)
2826 (setq end (point)))))
2827 (if (not (eq beg end))
2828 (setq ret (buffer-substring beg end)))
2831 ;;; ----------------------------------------------------------------------
2832 ;;; #not fully tested
2833 ;;; - Why did I do this after all ?
2834 ;;; - This won't work if cursor it at SPACE and BOL and user wants
2838 (defun ti::buffer-read-nth-word (&optional count mode back charset)
2839 "Read COUNT nth word in line.
2843 COUNT defaults to 0 ,current word according to MODE.
2844 MODE nil count from the bol/eol.
2845 'end count from the bol/eol, stop at eol/bol
2846 'this start counting from this position
2847 'thisEnd start counting from this position, stop at eol/bol
2848 BACK read backward. Affects the mode parameter.
2849 CHARSET use charset as \"word\", otw defaults to mode's
2854 (ti::buffer-read-nth-word) ,return first word in line
2855 (ti::buffer-read-nth-word 5 'end) ,return 5th word, but stop at eol
2857 ;; return 5th word, counting backwards stopping at bol. Read the word
2858 ;; with charset a-zA-z.
2860 (ti::buffer-read-nth-word 5 'end 'back \"a-zA-Z\")
2864 You get different results, if point is already sitting at word, or
2865 if it's sitting at whitespace, when using 'this modes.
2866 Try yourself with `forward-word' command.
2868 REMEMBER THAT WORD IS MODE DEPENDENT (syntax tables)
2873 nil nth word does not exist."
2874 (let* ((next-func (if back 'backward-word 'forward-word))
2875 (prev-func (if back 'forward-word 'backward-word))
2876 (next-skip (if back 'skip-chars-backward 'skip-chars-forward))
2877 (cmp-func (if back '< '>))
2878 (count (or count 0))
2882 ;; ... ... ... ... ... ... ... ... ... ... ... ... ... set limits ...
2883 (if (memq mode '(end nil)) ;starting position
2884 (if back (line-end-position) (line-beginning-position)))
2885 (if (memq mode '(end thisEnd)) ;setting the limit value
2886 (setq limit (if back (line-beginning-position) (line-end-position))))
2888 ;; Skip over spaces, stay put ...
2889 (if (ti::char-in-list-case (following-char) '(?\t ?\ ))
2890 (funcall next-skip " \t"))
2891 (funcall next-func count)
2892 (if (ti::char-in-list-case (following-char) '(?\t ?\ ))
2893 (funcall prev-func 1)))
2895 (funcall cmp-func (point) limit))
2899 (setq ret (ti::buffer-read-word charset)))
2901 (require 'thingatpt)
2902 ;; silence Bytecomp.
2903 (setq ret (ti::funcall 'word-at-point)))))
2907 ;;{{{ buffer: replacing, modifying lines
2909 ;;; ..................................................... &b-replacing ...
2911 ;;; ----------------------------------------------------------------------
2913 (defun ti::buffer-replace-keywords-with-table (keys)
2914 "Function to replace string a with string b.
2915 A and b are stored in a structure and b may be the result of a
2916 computation in itself. In other words, say we have a list of dotted
2919 ((\"$$AUTHORNAME$$\" . \"Charles R Martin\")
2920 (\"$$TIMESTAMP$$\" . (current-time-string))
2922 then the function skips through the buffer doing replace-string
2923 $$AUTHORNAME$$ 'Charles R Martin' followed by replace-string
2924 $$TIMESTAMP$$ (results of 'current-time-string')."
2928 (completing-read "Replace keywords using table: "
2932 (listp (symbol-value e)))))))))
2935 (goto-char (point-min))
2936 (while (search-forward (car x) nil t)
2937 (replace-match (eval (cdr x))))))
2940 ;;; ----------------------------------------------------------------------
2942 (defsubst ti::buffer-replace-region-with (beg end string &optional keep-point)
2943 "Replace region BEG END with STRING.
2944 Point is after the inserted string or if KEEP-POINT is non-nil
2945 then point is at BEG."
2946 ;; Prevent accidental delete
2947 (if (not (stringp string))
2948 (error "Input error."))
2949 ;; mimic "r" tag region, do not kill that extra char.
2950 (delete-region beg end)
2956 ;;; ----------------------------------------------------------------------
2957 ;;; The basic code for this was borrowed from zap-to-char in simple.el
2958 ;;; (define-key esc-map "Z" 'zap-to-regexp) ; originally 'zap-to-char
2960 (defun ti::buffer-zap-to-regexp (arg regexp)
2961 "Kill up to and including ARG'th occurrence of REGEXP.
2962 Goes backward if ARG is negative; error if REGEXP not found."
2963 (interactive "p\nsZap to regexp: ")
2967 (search-forward-regexp regexp nil nil arg)
2968 ;; This line makes zap-to-regexp behave like
2969 ;; d/ and d? in vi (ie with forward deletion
2970 ;; the regexp is left intact). Is this
2971 ;; really the right thing? zap-to-char
2972 ;; dropped this behavior. Was there a good
2973 ;; reason? I like this behavior since I use
2974 ;; vi frequently enough to get some benefit
2975 ;; from the orthogonality.
2976 (if (>= arg 0) (search-backward-regexp regexp 1))
2977 ;; p.s. Yes I know the '=' doesn't really do
2981 ;;; ----------------------------------------------------------------------
2982 ;;; #defalias (defalias 'leave-nth-word 'ti::buffer-leave-nth-word)
2983 ;;; - This is great function if you have some column output generated
2984 ;;; by SQL call or shell call, and you just want THOSE words left...
2987 (defun ti::buffer-leave-nth-word (beg end &optional nbr strict)
2988 "Delete all between BEG and END except nth word NBR.
2989 Default word nbr is 1, ie. the first word in the line.
2990 The word is considered as space separated entity.
2992 REMEMBER that word is mode dependent !
2996 NBR which word top leave on line, range 1..x
2997 STRICT if non-nil then if word NBR is not found delete whole line"
2998 (interactive "*r\nP")
2999 (let* ((nbr (or nbr 1))
3002 (narrow-to-region beg end) (ti::pmin)
3005 (setq word (ti::buffer-read-nth-word nbr 'end))
3009 (delete-region (line-beginning-position) (line-end-position))
3012 ((and (null word) strict)
3013 (ti::buffer-kill-line)) ;already does fwd-line
3015 (forward-line 1)))))))
3017 ;;; ----------------------------------------------------------------------
3018 ;;; - Easiest would have been using zap-to-char, but
3019 ;;; it's not same in 18.xx and 19.xx
3020 ;;; #todo: detect 19.xx and use zap, it's much quicker
3023 (defun ti::buffer-kill-line (&optional delete count)
3024 "Kill line and move next line up.
3025 If cursor is sitting at the end of buffer, nothing happens.
3029 DELETE use `delete-region', which doesn't manipulate `kill-ring',
3030 thus the execution is faster.
3031 COUNT how many lines to wipe.
3035 Between any emacs versions 18.xx - 19.xx
3044 nil sitting at eob, cannot kill line"
3046 (let* ((null-line-re "^$")
3047 (count (or count 1))
3050 ;; emacs kill-line is little awkward, because if you're at the
3051 ;; end of buffer it signals an error...
3056 ((eobp) ;nothing to kill
3058 ((and (null (eobp)) (looking-at null-line-re))
3066 (delete-region (point) (line-end-position))
3074 ;;; ----------------------------------------------------------------------
3076 (defun ti::buffer-strip-control-m () ;;#todo: Emacs function?
3077 "Remove control-M characters from buffer."
3078 (with-buffer-modified
3081 (while (re-search-forward "\r+$" nil t)
3082 (replace-match "" t t)))))
3084 ;;; ----------------------------------------------------------------------
3085 ;;; #defalias (defalias 'u2d 'ti::buffer-lf-to-crlf)
3087 (defun ti::buffer-lf-to-crlf (&optional arg force)
3088 "Simple Unix to Dos converter. If ARG is non-nil --> Dos to Unix.
3089 Strips or inserts ^M (return) marker _only_ at the end of line.
3091 If optional FORCE is given, ignores possible write protection.
3094 (if (ti::file-dos-p)
3095 (ti::buffer-lf-to-crlf 'Dos2unix 'doReadOnly))"
3097 (let* ((stat buffer-read-only))
3100 (prog1 force (setq buffer-read-only nil))) ;turn it off
3101 ;; - We use unwind, because the buffer read only status must be
3102 ;; restored. User may get anxious and press C-g for large buffers...
3103 ;; - I wonder if we can clear the buffer-modified flag too?
3104 ;; we leave it untouched for now...
3107 (goto-char (point-min)) ; start at the be.g. of file
3109 ;; ..................................... Dos --> unix ...
3111 (while (search-forward "\015\n" nil t)
3112 (replace-match "\n"))
3115 ;; Maybe last line does not have newline?
3116 (when (looking-at ".*\015$")
3118 (delete-backward-char 1)))
3119 ;; ....................................... unix --> dos ...
3121 (if (not (char= (preceding-char) ?\015))
3126 (if (not (char= (preceding-char) ?\015))
3129 (setq buffer-read-only stat))))))
3131 ;;; ----------------------------------------------------------------------
3133 (defun ti::buffer-arrow-control (buffer &optional mode str pos)
3134 "Controls showing the arrow glyph.
3137 BUFFER Where to put the arrow, must be visible.
3138 MODE 'show show the arrow with optional STRING
3139 'hide remove the arrow. If STR is given, change the value
3140 of `overlay-arrow-position'. This is usually for restoring
3141 the original content.
3142 'move move to current bol position or to POS. STR argument is
3146 STR arrow string to use, defaults to \"=>\"
3147 POS any position, converted to beginning of line
3148 [Emacs docs say the arrow must be at bol]"
3150 ;; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ show ^^^
3151 ((or (eq mode 'show)
3153 ;; We do not touch the arrow definition, if 'move is the mode
3155 (setq overlay-arrow-string
3156 (if (stringp str) str "=>")))
3157 (or overlay-arrow-position
3158 (setq overlay-arrow-position (make-marker)))
3159 (set-marker overlay-arrow-position
3163 (line-beginning-position))
3164 (line-beginning-position))
3166 ;; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ hide ^^^
3168 (if overlay-arrow-position ;Kill the marker
3169 (set-marker overlay-arrow-position nil))
3171 (setq overlay-arrow-string str)))))
3172 ;; - Here should be some kind of buffer refresh, since
3173 ;; the markes isn't hidden, if you're using read-char,
3174 ;; instead of read-from-minibuffer. See [tinyreply.el] for hack.
3175 ;; - Anybody knows how to refresh the view, please MAIL ME!!
3176 ;;; Not working, I thought moving the cursor would refresh arrow state
3178 ;;; (select-window (get-buffer-window buffer))
3179 ;;; (set-buffer buffer)
3180 ;;; (goto-char (line-beginning-position)))
3182 ;;; ----------------------------------------------------------------------
3183 ;;; #defalias (defalias 'nl 'ti::buffer-insert-line-numbers), see unix nl(1)
3185 ;;; -- or is this better ?
3186 ;;; #defalias (defalias 'insert-lines-numbers 'ti::buffer-insert-line-numbers)
3188 (defun ti::buffer-insert-line-numbers (beg end &optional line grow format)
3189 "Insert line numbers to buffer.
3190 Mark the region where to insert the line numbers.
3192 The default line format is '%02d:%s' for values lower that 100.
3193 For bigger values the format is dynamical (digit len derived from
3198 BEG END point area bounds
3199 LINE nbr starting line number. 1 is default
3200 GROW nbr grow count. 1 is default
3201 FORMAT str how line is formatted, see above
3206 ;; We input number as string so that user may press return
3208 (interactive "*r\nsStart line[1]: \nsInterval[1]: ")
3210 ;; convert strings to sensible value
3212 ((integerp line) ;; calling lisp
3215 (if (eq 0 (length line))
3217 (string-to-int line)))))
3222 (if (eq 0 (length grow))
3224 (string-to-int grow)))))
3225 (digits (ti::digit-length count))
3226 ;; Select "02d" when numbers < 100
3227 ;; Otw, select "digits" len.
3232 (if (or (= digits 1) (eq digits 2))
3237 (narrow-to-region beg end)
3240 (setq line (ti::read-current-line))
3241 (if (not (string-equal "" line))
3242 (delete-region (point) (line-end-position)))
3244 (insert (format fmt count line))
3245 (setq count (+ count factor))
3247 (forward-line 1)))))
3249 ;;; ----------------------------------------------------------------------
3250 ;;; - There must be removing function too.. :-)
3251 ;;; #defalias (defalias 'remove-line-numbers 'ti::buffer-remove-line-numbers)
3253 (defsubst ti::buffer-remove-line-numbers (beg end &optional re level)
3254 "Remove line numbers from region BEG END.
3255 The Default line numbers are sticked to the left and have form
3259 where xxx represent some numbers.
3261 You can supply optional RE and regexp LEVEL that should be
3262 removed. E.g. in normal, above case the
3265 LEVEL = 0 ,match whole regexp"
3267 (ti::buffer-replace-regexp
3275 ;;; ----------------------------------------------------------------------
3277 (defun ti::buffer-randomize-lines (beg end)
3278 "Scramble all the lines in region BEG END.
3279 If region contains less than 2 lines, lines are left untouched."
3283 (narrow-to-region beg end)
3284 ;; Exit when there is not enough lines in region
3285 (if (< (- (point-max) (point-min)) 3)
3287 ;; Prefix lines with a random number and a space
3288 (goto-char (point-min))
3290 (insert (int-to-string (random 32000)) " ")
3292 ;; Sort lines according to first field (random number)
3293 (sort-numeric-fields 1 (point-min) (point-max))
3294 (goto-char (point-min)) ;Remove the prefix fields
3296 (delete-region (point) (progn (forward-word 1) (+ (point) 1)))
3297 (forward-line 1)))))
3299 ;;; ----------------------------------------------------------------------
3301 (defun ti::buffer-make-dup-line (&optional count)
3302 "Copy the current line COUNT times (default is 1) below the current line."
3304 (setq count (or count 1))
3307 (let ((line (buffer-substring
3309 (progn (forward-line 1) (point)))))
3312 (setq count (1- count))))))
3314 ;;; ----------------------------------------------------------------------
3316 (defun ti::buffer-inc-string-nbr (re inc-val increment &optional level)
3317 "Search string and increment integers.
3321 RE regexp to match integer. Subexpr 1 assumed in interactive call
3322 INC-VAL start value.
3323 INCREMENT Step how much to increment every time.
3324 LEVEL Subexpression in regexp to match the integer portion.
3326 E.g. I you have just paste same variable on the lines multiple times
3334 And now you want to make them unique:
3342 You just give RE \"r\\([0-9]+\\)\" and start value 1, increment 1"
3343 (interactive "sRE: \nnstart value: \nnIncrement: ")
3344 (let* ((level (or level 1))
3349 (while (re-search-forward re nil t) ;search whole buffer
3350 (when (match-end level)
3351 (setq beg (match-beginning level)
3352 end (match-end level)
3354 fmt (concat "%0" (int-to-string len) "d"))
3355 (delete-region beg end)
3357 (insert (format fmt inc-val))
3358 (incf inc-val increment)))))
3360 ;;; ----------------------------------------------------------------------
3361 ;;; - Here is slightly different version. this increments every number
3362 ;;; whereas the previous would increment only SUBMATCH by STEP
3364 ;;; - E.g. copying the first line produces:
3366 ;;; assign pi0_vld = (opc_i0 === alu0);
3367 ;;; assign pi1_vld = (opc_i1 === alu1);
3369 (defun ti::buffer-copy-line-and-inc-numbers (&optional increment)
3370 "Copy line, preserving cursor column, and INCREMENT any numbers found.
3371 Prefix ARG is the increment value. Defaults to 1."
3373 (let* ((col (current-column))
3374 (line (ti::read-current-line))
3375 (increment (if (integerp increment) increment 1))
3380 ;; We have to use markers, because the line is modified.
3381 (setq mark (point-marker))
3383 (while (re-search-forward "[0-9]+" (marker-position mark) 1)
3384 (setq len (length (match-string 0)))
3385 (setq num (string-to-int (match-string 0)))
3386 ;; E.g. 0001 --> 0002
3387 (setq out (format (concat "%0" (int-to-string len) "d")
3389 (replace-match out))
3392 (move-to-column col t)
3396 ;;; ----------------------------------------------------------------------
3398 (defun ti::buffer-copy-word (n)
3399 "Copy N words above the current line.
3400 If there is no words above the line, then do nothing."
3402 (let ((column (current-column))
3409 (move-to-column column t)
3410 (setq copy (buffer-substring
3412 (min (save-excursion (end-of-line) (point))
3413 (save-excursion (forward-word n) (point)))))))
3417 ;;; ----------------------------------------------------------------------
3418 ;;; #defalias (defalias 'double-space-region 'ti::buffer-newlines-to-region)
3420 (defun ti::buffer-add-newlines-to-region (beg end &optional arg)
3421 "Insert to to the end of each line in region BEG END ARG newlines.
3422 Default is to inser one which makes lines make double spaced."
3423 (interactive "*r\np")
3425 (narrow-to-region beg end)
3427 (while (search-forward "\n" nil t)
3429 (concat "\n" (make-string arg ?\n))
3432 ;;; ----------------------------------------------------------------------
3433 ;;; - STRICT parameter can be used from lisp call
3434 ;;; #defalias (defalias 'remove-blank-lines 'ti::buffer-cnv-empty-lines)
3436 (defun ti::buffer-cnv-empty-lines (beg end &optional nbr strict)
3437 "Convert empty lines in region BEG END to zero empty lines.
3438 Optionally leaves NBR empty lines. If STRICT is non-nil, all lines
3439 must have NBR amount of empty lines, no more or less.
3441 Point is not preserved."
3442 (interactive "*r\nP")
3443 (let* ((empty-line-re "^[ \t]+$\\|\n")
3444 (nbr (or nbr 0)) ;default is to leave no empty lines
3445 pb pe ;points beg, end
3449 (narrow-to-region beg end)
3452 (if (null (looking-at empty-line-re))
3454 (setq pb (point)) (skip-chars-forward " \t\n")
3455 (beginning-of-line) (setq pe (point))
3456 ;; There is a bug in count-lines, that's why we
3457 ;; use line-end-position,
3458 ;; not 'pe' to count the lines in region
3459 (setq count (count-lines pb (line-end-position)))
3461 ;; ...................................................... cond ...
3465 nil ;not that many lines here
3469 ;; .................................................... action ...
3472 (forward-line 1)) ;skip
3474 (delete-region pb pe)
3476 (while (> count 0) ;leave that many
3477 (decf count) (insert "\n"))
3480 ;; nothing done, next line
3481 (forward-line)))))))))
3483 ;;; ----------------------------------------------------------------------
3484 ;;; #defalias (defalias 'delete-duplicate-lines 'ti::buffer-del-dup-lines)
3486 ;;; - Letting shell to do the job is the fastest, cleanest
3487 ;;; way. Sometimes lisp just isn't the right tool...
3489 ;;; A. Want to do it fast?
3490 ;;; Camel book has ready code for this. Pg 228
3491 ;;; $ perl -ne 'print unless $seen{$_}++' file.in > file.out
3493 ;;; B. How about running a shell command over the region/buffer
3494 ;;; with command "uniq"? This filters successive lines.
3495 ;;; C-x h , ESC-| uniq RET
3498 (defun ti::buffer-del-dup-lines(beg end &optional len white-lines)
3499 "Deletes duplicate lines in buffer. Optionally compares first LEN
3500 characters to determine line equality.
3505 LEN portion of line: chars to compare
3506 WHITE if non-nil, don't touch whitespace only lines.
3510 Call shell with small PERL program. Make sure PERL is along the path.
3512 (interactive "*r\nP")
3515 (narrow-to-region beg end)
3522 (concat "$line = substring($_,0, "
3528 "/^\\s*$/ && do{print; next;};")
3529 "print unless $seen{$line}++;"
3531 (shell-command-on-region
3538 ;;; ----------------------------------------------------------------------
3540 (defun ti::buffer-delete-until-non-empty-line (&optional backward point)
3541 "Delete all lines starting from current point.
3542 Stop on [be]obp or non-empty line. Optionally delete BACKWARD
3543 and start at POINT or current position.
3545 Moves point to the beginning of non-empty line."
3551 (setq point (point))
3554 (while (and (not (bobp))
3555 (looking-at "^[ \t]*$"))
3559 (while (and (not (eobp))
3560 (looking-at "^[ \t]*$"))
3562 (setq end (point)))))
3564 (delete-region point end))))
3566 ;;; ----------------------------------------------------------------------
3567 ;;; - The delete-region, according to emacs C-developers,
3568 ;;; is _lighting_ fast way to do deletions in emacs.
3570 (defun ti::buffer-trim-blanks (beg end)
3571 "Delete trailing blanks in region BEG END."
3575 (narrow-to-region beg end)
3576 ;; _much slower would be: (replace-regexp "[ \t]+$" "")
3577 (goto-char (point-min))
3580 (delete-horizontal-space)
3582 nil) ;for possible hook
3584 ;;; ----------------------------------------------------------------------
3586 (defun ti::buffer-replace-regexp (re level str &optional back beg end)
3587 "Like `replace-regexp' but for Lisp programs.
3588 Lisp info page says in \"Node: Style Tip\", that lisp programs shouldn't
3589 use `replace-regexp', so here is identical function that doesn't touch
3590 the mark. The point is left after last match.
3596 STR string used in replacing.
3597 BACK replace backward
3598 BEG END region. If both BEG and END is given, the
3599 BACK parameter is ignored."
3600 (let* ((func (if back 're-search-backward 're-search-forward))
3603 (if (not (integerp level)) ;common error
3604 (error "Level is not integer."))
3607 (setq bp beg ep end func 're-search-forward))
3609 (setq bp (point) ep (point-min)))
3611 (setq bp beg ep (point-min)))
3612 ((and (not back) beg)
3613 (setq bp beg ep (point-max)))
3614 ((and (not back) end)
3615 (setq bp (point) ep end))
3617 (setq bp (point) ep (point-max))))
3619 (narrow-to-region bp ep)
3621 (while (and (funcall func re nil t)
3623 (if (null (match-end level)) nil ;not matched
3624 (ti::replace-match level)
3625 ;; point is at the end of STR inserted
3631 ;;; ..................................................... &buffer-misc ...
3633 ;;; ----------------------------------------------------------------------
3635 (defun ti::buffer-diff-type-p ()
3636 "Check the diff type in buffer.
3637 Assumes that whole buffer contains diff. Searches for traces.
3638 Lines must be left flushed.
3640 *** /tmp/T.11 Fri Oct 20 12:22:51 1995
3641 --- /tmp/T.1 Fri Oct 20 12:24:29 1995
3650 Gnu diff -n (or --rcs, Output an RCS format diff)
3654 (tdi-goto-kbd 'verb)
3658 Gnu diff -u (unified diff)
3663 endChargeTime[16+1];
3672 (TYPE . POS) ,POS is the diff start position
3676 'context ,context diff -c
3679 'normal ,normal diff
3682 character position where the first diff was found"
3683 (let* ((re-c1 "^[ \t]*[*][*][*] [0-9]") ;context diff regexps
3685 ;; The normal diff line is following, but PGP breaks it.
3686 ;; That's why we have those ? ? in thge regexp
3690 (re-c2 "^-? ?--- .")
3691 (re-c3 (concat "^" (regexp-quote "***************")))
3692 (re-n1 "^[0-9]+[dca][0-9]+$\\|^[0-9]+,[0-9]+[dca][0-9]")
3695 (re-gn1 "^[dac][0-9]+ [0-9]+$")
3696 (re-gu1 "^@@ [-+][0-9]+,[0-9]+[ \t]+[-+]+")
3703 ;; ... ... ... ... ... ... ... ... ... ... ... ... ... context ..
3704 ((and (re-search-forward re-c1 nil t)
3705 (setq pos (line-beginning-position))
3712 (looking-at re-c3))))
3715 (looking-at re-c3))))
3716 (setq type 'context))
3717 ;; ... ... ... ... ... ... ... ... ... ... ... ... ... . normal ..
3718 ((and (re-search-forward re-n1 nil t)
3719 (setq pos (line-beginning-position))
3722 (looking-at re-n2)))
3723 (setq type 'normal))
3724 ((re-search-forward re-gu1 nil t)
3725 ;; There is filename information above the diff start.
3732 ((and (re-search-forward re-gn1 nil t) ;require two same lines
3733 (setq pos (line-beginning-position))
3736 (looking-at re-gn1)))
3737 (setq type 'gnu-n)))
3739 (setq ret (cons type pos)))
3742 ;;; ----------------------------------------------------------------------
3744 (defun ti::buffer-outline-widen ()
3745 "Open folded/outlined buffer if some of the modes is active.
3746 You have to call this function if you want to do something for
3750 ;; Unfold the buffer, so that we can see all.
3751 ;; We must also preserve point
3753 (ti::save-with-marker-macro
3754 (and (boundp 'folding-mode)
3755 ;; No autoloads allowed, this makes sure the fboundp
3756 ;; is converted to real function. The ti::funcall command
3757 ;; cannot use autoload function.
3758 (progn (require 'folding) t)
3759 (if (symbol-value 'folding-mode) ;ByteComp silencer
3760 (ti::save-line-column-macro nil nil
3761 ;; ByteComp silencer
3762 (ti::funcall 'folding-open-buffer))))
3763 (and (eq major-mode 'outline-mode)
3765 (progn (require 'outline) t)
3766 (ti::save-line-column-macro nil nil
3767 (ti::funcall 'show-all)))
3768 (and (boundp 'outline-minor-mode)
3770 (progn (require 'outline) t)
3771 (ti::save-line-column-macro nil nil
3772 (ti::funcall 'show-all)))))
3774 ;;; ----------------------------------------------------------------------
3776 (defun ti::buffer-buffer-list-files (&optional re str)
3777 "Return all files loaded into Emacs.
3779 If optional RE and STR are given, then a file name substitution
3782 args RE = \"/usr43/users/john/\" STR = \"~/\"
3783 buffer file \"/usr43/users/john/t.txt\"
3784 substituted \"~/t.txt\"
3788 (ti::buffer-buffer-list-files \"/usr43/users/john\" \"~\")
3792 (filename ..) list of filenames"
3795 (dolist (elt (buffer-list))
3796 (setq file (buffer-file-name elt))
3797 (when (stringp file) ;might be nil if buffer has no file
3799 (string-match re file))
3800 (setq file (ti::replace-match 0 str file)))
3804 ;;; ----------------------------------------------------------------------
3806 (defun ti::buffer-count-words (beg end)
3807 "Count words in region BEG END."
3809 (let ((msg (count-matches "\\w*" beg end)))
3811 (string-match "\\([0-9]+\\)" msg))
3812 (string-to-int msg))))
3814 ;;; ----------------------------------------------------------------------
3815 ;;; - This is quite a handy function when you're programming e.g.
3816 ;;; in C++ and want to know how many chars are in the string.
3818 (defun ti::buffer-count-chars-in-delimited-area (arg &optional verb)
3819 "Counts characters within quotes. ARG C - u to search single quotes.
3820 Other argument invokes asking the beginning delimiter: if you give
3821 \"(\" the end delimiter is automatically set to \")\".
3822 This function is mainly for interactive use. VERB.
3825 nbr count of characters
3826 nil begin or end delimiter was not found"
3828 (let* ((alist '(( ?\( ?\) )
3833 (verb (or verb (interactive-p)))
3842 ;; ... ... ... ... ... ... ... ... ... ... ... ... . preliminaries ...
3850 (message "Begin delimiter char: ")
3851 (setq beg-ch (read-char))
3853 (if (setq elt (assq beg-ch alist))
3855 ;; Can't find match for it, so use same char
3856 ;; for both delimiters
3859 (if re ;now, what we got?
3860 (setq beg-re (regexp-quote re) end-re beg-re)
3861 (setq beg-re (regexp-quote (char-to-string beg-ch))
3862 end-re (regexp-quote (char-to-string end-ch))))
3863 ;; ... ... ... ... ... ... ... ... ... ... ... ... ... ... . do it ...
3865 (if (null (re-search-forward end-re nil t))
3867 (message (concat "Can't find end mark: " end-re)))
3868 (setq point (point))
3869 ;; the re-search-forward leaves point after the char,
3870 ;; we have to go small step back before we change the direction.
3872 (if (null (re-search-backward beg-re nil t))
3874 (message (concat "Can't find beginning mark: " beg-re)))
3875 ;; the -2 excludes the markers itself.
3877 (setq ret (- (length
3878 (buffer-substring point (point)))
3881 (message (concat (int-to-string ret) " characters."))))))
3884 ;;; ----------------------------------------------------------------------
3886 (defun ti::buffer-word-move (set &optional back)
3887 "Move to next word defined in SET, optionally BACK.
3888 SET must be string, that can be turned into regexp and that can
3889 be used with skip-chars functions.
3891 E.g. \"-[]$%@#&*\":;{}()<>/\\ \t\n\""
3893 (let* ((nset (concat "^" set)) ;not-set
3894 (set-re (concat "[" (regexp-quote set) "]"))
3895 (char (char-to-string
3902 (if (string-match set-re char)
3904 (skip-chars-backward set)
3905 (skip-chars-backward nset))
3906 ;; If we're over word already, this moves. But if we're
3907 ;; at the beginning of word this doesn't move.
3909 (skip-chars-backward nset)
3910 (when (eq (point) point)
3911 (skip-chars-backward set)
3912 (skip-chars-backward nset))))
3914 (if (string-match set-re char)
3916 (skip-chars-forward set)
3917 (skip-chars-forward nset))
3918 (skip-chars-forward nset)
3919 (skip-chars-forward set))))))
3921 ;;; ----------------------------------------------------------------------
3923 (defun ti::buffer-find-duplicate-same-word (&optional back)
3924 "Find consecutive occurrences of same word, optionally search BACK."
3926 (let* ((func (if back 're-search-back 're-search-forward)))
3927 (if (funcall func "\\(\\<\\w*\\>\\)[ \t\n]*\\1" nil t)
3928 (isearch-highlight (match-beginning 0) (match-end 0))
3931 ;;; ----------------------------------------------------------------------
3933 (defun ti::buffer-move-paragraph-to-column (beg end col)
3934 "Move text BEG END to column position COL.
3936 The indent is done in the following way:
3938 o Search first non-whitespace line starting from the beginning
3940 o count how much the line is indented: remove that indentation
3941 from all the rest of the lines.
3942 o Now when lines have no indet; reindent to COL
3944 The procedure described preserves the actual paragraph style, so that
3945 if text inside paragraph is more indented that the previous line the
3946 relative indent is preserved.
3948 txt txt txt txt txt txt
3949 txt txt txt txt txt txt
3950 inner indent txt txt txt
3951 inner indent txt txt txt
3952 txt txt txt txt txt txt
3953 txt txt txt txt txt txt
3957 beg always calculates to bol
3958 end always calculates to eol"
3959 (interactive "*r\np")
3963 (goto-char (min beg end)) ;Setting MIN
3964 (setq min (line-beginning-position))
3965 (goto-char (max beg end)) ;setting MAX
3967 (setq marker (point-marker)) ;Because untabify moves end
3968 (untabify min (marker-position marker))
3969 ;; Is there non whitespace line?
3972 ((re-search-forward "^[^ \n]" (marker-position marker) t)
3973 ;; non whitespace line found.
3974 ;; Do nothing -- indent directly
3976 ((re-search-forward "^\\( +\\)[^ \n]" (marker-position marker) t)
3977 ;; Remove this indentation.
3978 (when (> (setq len (length (or (match-string 1) ""))) 0)
3979 (indent-rigidly min (marker-position marker) (- 0 len) ))))
3980 ;; Now reindent the region
3981 (indent-rigidly min (marker-position marker) col) ;new
3985 ;;; ----------------------------------------------------------------------
3987 (defsubst ti::buffer-move-to-col (col)
3988 "Doesn't care about line length. Insert spaces to get to COL.
3989 Convert tabs to spaces to get to exact COL."
3990 (interactive "Nto col: ")
3991 (move-to-column col t)
3992 (if (not (eq (current-column) col))
3993 (while (< (current-column) col)
3997 ;;;(defun space-to-column (target)
3998 ;;; "Insert spaces as necessary to move pt to TARGET column."
3999 ;;; (interactive "p")
4000 ;;; (let ((cur (current-column)))
4001 ;;; (if (< cur target)
4002 ;;; (insert (make-string (- target cur) ? )))))
4005 ;;{{{ buffer: selective display
4007 ;;; ................................................... &misc-packages ...
4009 ;;; ----------------------------------------------------------------------
4010 ;;; - Separating the "effective display" is easy with this...
4013 (defun ti::buffer-selective-display-copy-to (beg end buffer &optional verb)
4014 "Copy region BEG END selective display to BUFFER. VERB.
4015 E.g. folding.el and outline based modes use selective display."
4018 (if (not (region-active-p))
4019 (error "Region not selected."))
4023 (read-from-minibuffer "To buffer: " "*selective display*"))))
4024 (let* ((bp (get-buffer-create buffer)) ;barfs if invalid...
4025 (bp (ti::temp-buffer bp 'clear)) ;ok, use it
4030 (narrow-to-region beg end)
4033 ;; - Reset for normal lines.
4034 ;; - Or reads until \r. I.e. the hidden part is not read
4035 (setq line (or (and (looking-at ".*\r")
4037 (ti::buffer-match "\\([^\r]+\\)+\r" 1)
4039 (ti::read-current-line)))
4041 (setq line (concat line "\n"))
4043 (ti::append-to-buffer bp line))))
4045 (pop-to-buffer bp))))
4047 ;;; ----------------------------------------------------------------------
4048 ;;; - Print folding.el and outline based buffer with this...
4050 (defun ti::buffer-selective-display-print (beg end)
4051 "Print selective display region BEG END."
4053 (let* ((buffer (generate-new-buffer "*print*")))
4056 (ti::buffer-selective-display-copy-to beg end buffer)
4057 (with-current-buffer buffer (print-buffer)))
4058 (kill-buffer buffer))))
4061 ;;{{{ Window, frames
4063 ;;; .......................................................... &window ...
4065 ;;; ----------------------------------------------------------------------
4067 (defun ti::window-frame-list (&optional all exclude-current win)
4068 "Return only frames that are non-dedicated.
4070 ALL if non-nil, return all frames.
4071 EXCLUDE-CURRENT if non-nil, exclude current active frame.
4072 WIN Use this is as a current window when searching
4074 (let* ((oframe (if win
4080 (setq flist (delete oframe (frame-list)))
4081 (setq flist (frame-list)))
4082 (dolist (frame flist)
4083 (select-frame frame)
4084 (if (or all (not (window-dedicated-p (selected-window))))
4085 (ti::nconc ret frame)))
4087 (select-frame oframe)) ;Return back to original
4090 ;;; ----------------------------------------------------------------------
4092 (defun ti::window-list (&optional buffers)
4093 "Gather all visible windows or BUFFERS visible in current frame."
4094 (let* ((s (selected-window)) ;start window
4096 (w s) ;current cycle
4100 (if buffers ;Start list
4101 (setq l (list (window-buffer s)))
4105 (setq ww (next-window w))
4107 (other-window 1) ;move fwd
4108 (if (eq ww s) ;back to beginning ?
4111 (if buffers ;list of buffers instead
4112 (setq ww (window-buffer ww)))
4113 (setq l (cons ww l))))
4116 ;;; ----------------------------------------------------------------------
4118 (defsubst ti::window-single-p ()
4119 "Check if there is only one window in current frame."
4120 ;; No need to run `length' when `nth' suffices.
4121 (let* ((win (selected-window))
4122 (next (next-window)))
4126 ;;; ----------------------------------------------------------------------
4128 (defun ti::window-get-buffer-window-other-frame (buffer)
4129 "Return (frame . win). If BUFFER is visible..
4130 in some other frame window than in the current frame."
4134 (delete (selected-frame) (frame-list)))
4135 ;; maybe in other frame...
4136 (when (setq win (get-buffer-window buffer frame))
4137 (setq ret (cons frame win))
4141 ;;; ----------------------------------------------------------------------
4142 ;;; - don't know good way how to generalize this to return either top/bottom
4143 ;;; window. I guess we just copy this and make small changes...
4144 ;;; - Does anyone have good suggestions to do therwise?
4146 (defun ti::window-find-bottom (win-list)
4147 "Find bottom window from WIN-LIST.
4148 Any non-visible window in list is skipped.
4149 If there are adjacent windows, return all of them.
4154 | | | | < three splitted windows at the bottom
4159 list single or many windows. In any order."
4167 (dolist (win win-list)
4168 (setq data (window-edges win))
4169 (if (null init) ;init vars
4170 (setq init t ;initalized ok
4171 win-val (list win) ;win comes from 'window-loop'
4175 (setq top-cmp (nth 1 data)
4176 bot-cmp (nth 3 data))
4178 ((> bot-cmp bot) ;this is more lower
4179 (setq win-val (list win)
4182 ((or (eq bot-cmp bot) ;hmm, same horizontal top row..
4183 (eq top-cmp top)) ;split sideways...
4185 ((or (eq bot-cmp bot) ; .........
4186 (> top-cmp top)) ; .... .
4187 ; ......... < pick lowest in left
4188 (setq win-val (list win)
4193 ;;; ----------------------------------------------------------------------
4195 (defun ti::window-match-buffers (buffer-name-list)
4196 "Check all windows that match BUFFER-LIST.
4200 BUFFER-NAME-LIST ,strings, list of buffer names.
4204 '((BUFFER-NAME WIN-PTR WIN-PTR ..)
4211 (dolist (win (ti::window-list))
4212 ;; last walue will tell the BOTTOM
4213 (setq buffer (buffer-name (window-buffer win)))
4215 ;; '((BUFFER-NAME WIN-PTR WIN-PTR ..)
4216 ;; (BUFFER-NAME ..))
4218 ((member buffer buffer-name-list) ;does it interest us ?
4220 ((not (setq ptr (assoc buffer alist))) ;; create initial element
4221 (push (list buffer win) alist))
4223 (setq p (cdr ptr)) ;drop 1st element away
4224 (ti::nconc p win) ;add new element
4225 ;; replace with new list
4230 ;;{{{ Key maps, translations
4232 ;;; ----------------------------------------------------------------------
4234 (defun ti::keymap-single-key-definition-p (key-def)
4235 "Check if KEY-DEF is a single key definition.
4236 E.g. If you want to check if prefix key is composed only from
4237 one key: \"a\" \"?\\C-a\" or even [(?a)].
4239 (ti::keymap-single-key-definition-p [ a ] ) --> a
4240 (ti::keymap-single-key-definition-p [(a)] ) --> a
4241 (ti::keymap-single-key-definition-p \"a\" ) --> a
4242 (ti::keymap-single-key-definition-p \"\\C-a\" ) --> C-a
4244 (ti::keymap-single-key-definition-p [(a) (b)] ) --> nil
4245 (ti::keymap-single-key-definition-p [(meta a)]) --> nil
4246 (ti::keymap-single-key-definition-p \"ab\" ) --> nil
4247 (ti::keymap-single-key-definition-p \"?C-ab\" ) --> nil
4251 If single key. Return it, either as character or symbol."
4253 ((and (stringp key-def) ;; "\C-a" or "a"
4254 (eq 1 (length key-def)))
4255 (string-to-char key-def))
4256 ((and (vectorp key-def) ;; [(ELT)] or [ELT]
4257 (eq 1 (length key-def))
4258 (eq 1 (length (elt key-def 0))))
4259 (let* ((ELT (elt key-def 0))
4260 (item (if (listp ELT) ;; was [(ELT)]
4262 ELT)) ;; otherwise [ELT]
4263 ;; At this point; convert to string
4265 ((symbolp item) ;; mouse-1 ot the like
4267 ((characterp item) ;; was it ?a ==> [(?a)]
4269 ((and (stringp item)
4270 (eq 1 (length item)))
4271 (string-to-char item)))))
4275 ;;; ----------------------------------------------------------------------
4277 (defun ti::keymap-define-key-backspace ()
4278 "Move C-h to Backspace if this is non-windowed Emacs.
4279 Key C-x C-? replaces original C-x C-h.
4280 Key C-c h replaces original C-h call
4283 (let* (;;; (DELETE "\C-h")
4285 (unless (ti::compat-window-system)
4286 (defvar key-translation-map (make-sparse-keymap))
4287 ;; If it's nil then something is wrong. Fix it.
4288 (unless key-translation-map
4289 (setq key-translation-map (make-sparse-keymap)))
4290 ;; This keymap works like `function-key-map', but comes after that,
4291 ;; and applies even for keys that have ordinary bindings.
4292 (define-key key-translation-map "\177" "\C-h")
4293 (define-key key-translation-map "\C-h" "\177")
4294 (global-set-key BACKSPACE 'backward-delete-char)
4297 (message "tinylib: Warning, key already occupied: %s %s"
4299 ;; (ti::define-key-if-free global-map
4300 ;; "\C-x\C-?" 'help-for-help 'key-warning)
4301 (ti::define-key-if-free global-map
4302 "\C-ch" 'help-command 'key-warning)))))
4304 ;;; ----------------------------------------------------------------------
4306 (defun ti::keymap-function-bind-info (function-sym &optional map)
4307 "Return binding information for FUNCTION-SYM from MAP as string or nil."
4308 (let* ((gm (current-global-map))
4312 (setq global-bindings (where-is-internal function-sym)
4315 ;; We have to set this to nil because where-is-internal
4316 ;; searches global map too. We don't want that to happen
4318 (use-global-map (make-keymap))
4321 (or map (current-local-map)))
4322 (use-global-map gm)))
4325 (if (or global-bindings local-bindings)
4329 (mapcar 'key-description
4332 (if (and global-bindings local-bindings)
4336 (format "local to %s"
4337 (mapcar 'key-description
4342 ;;; ----------------------------------------------------------------------
4344 ;;; because of the nature of minor modes, changes in the maps
4345 ;;; are not reflected unless, the minor mode is installed again
4347 ;;; The following removes minor keymap, if it exists,
4348 ;;; and reinstalls it with new added bindings.
4350 (defun ti::keymap-reinstall-minor-mode (mode-name-symbol)
4351 "Reinstall minor mode MODE-NAME-SYMBOL.
4352 This is needed if you have made changes to minor modes keymaps.
4353 They don't take in effect until you reinstall the minor mode.
4356 t minor mode found and reinstalled
4357 nil no susch minor mode."
4363 (when (setq elt (assq mode-name-symbol minor-mode-alist))
4364 (setq mode-string (nth 1 elt))
4365 (setq elt (assq mode-name-symbol minor-mode-map-alist))
4368 (error "No map for minor mode %s" mode-name-symbol))
4370 (symbol-name mode-name-symbol)
4372 (setq map-sym (intern-soft sym))
4373 (if (or (null map-sym)
4374 (not (keymapp (setq map (eval map-sym)))))
4375 (error "The keymap was not found %s" map-sym))
4376 (ti::keymap-add-minor-mode mode-name-symbol nil nil 'remove)
4377 (ti::keymap-add-minor-mode mode-name-symbol mode-string map))))
4379 ;;; ----------------------------------------------------------------------
4380 ;;; - Why doesn't emacs offer this simple interface by default ?
4382 (defun ti::keymap-add-minor-mode
4383 (mode-func-sym mode-name-sym mode-map &optional remove)
4384 "Add the minor mode into Emacs. If mode exists, do nothing.
4388 MODE-FUNC-SYM function symbol, mode to turn on
4389 MODE-NAME-SYM variable symbol to hold mode name string
4391 REMOVE OPTIONALLY removes mode with mode-name-sym
4396 (ti::keymap-add-minor-mode 'foo-mode 'foo-mode-name foo-mode-map)
4399 (ti::keymap-add-minor-mode 'foo-mode nil nil 'remove)"
4404 (or (assq mode-func-sym minor-mode-map-alist)
4405 (setq minor-mode-map-alist
4406 (cons (cons mode-func-sym mode-map)
4407 minor-mode-map-alist)))
4408 ;; Update minor-mode-alist
4409 (or (assq mode-func-sym minor-mode-alist)
4410 (setq minor-mode-alist
4411 (cons (list mode-func-sym mode-name-sym)
4412 minor-mode-alist))))
4414 (and (setq elt (assq mode-func-sym minor-mode-map-alist))
4415 (setq minor-mode-map-alist (delq elt minor-mode-map-alist)))
4417 (and (setq elt (assq mode-func-sym minor-mode-alist))
4418 (setq minor-mode-alist (delq elt minor-mode-alist)))))))
4420 ;;; ----------------------------------------------------------------------
4422 (defun ti::keymap-bind-control (map-symbol get-set prop key)
4423 "Get or set the stored property binding in map.
4424 This is a good function to use if you modify the original
4425 bindings in the map. You can then call the original
4426 function behind the binding in your modified function.
4432 'get = return previous property value (key definition)
4433 'set = copy definition once.
4434 'sett = (force) copy definition even if already copied.
4435 The 'set copies the key definition behind the propert
4436 PROP only if there is no previous value. 'sett
4437 replaces the content of PROPERTY.
4439 KEY string -- key binding.
4443 (ti::keymap-bind-control 'mail-mode-map 'set 'my \"\\C-c\\C-c\")
4444 --> mail-send-and-exit, saved to property 'my
4446 (ti::keymap-bind-control 'mail-mode-map 'set 'my \"\\C-c\\C-c\")
4447 --> nil, property 'my Was already set
4449 (ti::keymap-bind-control 'mail-mode-map 'get 'my \"\\C-c\\C-c\")
4450 --> mail-send-and-exit, get the saved property 'my.
4454 ;; - first save original, then use our function. Use property
4455 ;; 'my, because The C-c C-c can already be occupied by
4456 ;; some other package...
4457 ;; - it calls the original afterwards
4459 (ti::keymap-bind-control 'mail-mode-map 'set 'my \"\\C-c\\C-c\")
4460 (define-key mail-mode-map \"\\C-c\\C-c\" 'my-mail-func-CcCc)
4462 (defun my-mail-func-CcCc (arg)
4464 (funcall ;; Call the original.
4465 (ti::keymap-bind-control 'mail-mode-map 'get 'my \"\C-c\C-c\")
4467 ;; Function ends here.)"
4473 (unless (boundp map-symbol)
4474 (error "No variable bound %s" map))
4475 (setq map (eval map-symbol))
4476 (unless (keymapp map)
4477 (error "Not a keymap %s" map-symbol))
4478 (if (or (ti::nil-p key) ;must be valid string
4479 (not (stringp key)))
4480 (error "Invalid KEY %s" key))
4481 (setq map-key (concat (symbol-name map-symbol) key))
4482 (setq func (lookup-key map key))
4483 (when func ;does function exist?
4484 (setq sym (intern map-key)
4489 ((and (eq get-set 'set)
4490 (null val)) ;set only if PROP not exist
4491 (put sym prop func))
4492 ((eq get-set 'sett) ;replace value
4493 (put sym prop func))))))
4495 ;;; ----------------------------------------------------------------------
4496 ;;; - What is an translate table?
4497 ;;; - Well; it says "if you press this key I give you this character back"
4498 ;;; - It is used for remapping the keys, but beware! In X envinronment,
4499 ;;; where you can paste data between emacs, the translation gives
4500 ;;; unpleasant results. Try pasting the _normal_ \ char from other
4501 ;;; window to emacs that uses transltion presented in example below.
4502 ;;; --> you get the | character pasted into Emacs
4504 (defun ti::keymap-translate-table (&optional arg)
4505 "Make new translate table.
4509 'use Start using the new table if the
4510 `keyboard-translate-table' if nil. Otherwise does nothing.
4511 'use-new replace current table with fresh one
4512 nil return new, default translate table.
4516 Switch these keys. Let's assume the \\ key is on top after this,
4517 since it is used more often in emacs.
4519 (ti::keymap-translate-table 'use)
4520 (aset keyboard-translate-table ?\\| ?\\\\ )
4521 (aset keyboard-translate-table ?\\\\ ?\\| )
4525 new translate table"
4527 (xlat-table (make-string 128 0)))
4528 (while (< index 128) ;Generate the identity map.
4529 (aset xlat-table index index)
4530 (setq index (1+ index) ))
4533 (setq keyboard-translate-table xlat-table))
4535 (and (null keyboard-translate-table)
4536 (setq keyboard-translate-table xlat-table)))
4540 ;;; ----------------------------------------------------------------------
4541 ;;; - For preventing Emacs to beep and disabling the normal keys
4542 ;;; (for mail, gnus, ... )
4544 (defun ti::keymap-put-abc-map (map &optional func)
4545 "Put function `ignore' to abc key MAP, optionally put FUNC."
4547 (func (or func 'ignore))
4551 ;; Set lowercase/upcase keys to nil
4552 (setq low (char-to-string (+ 65 i))
4553 up (char-to-string (+ 97 i)))
4554 (define-key map low func)
4555 (define-key map up func)
4558 ;;; ----------------------------------------------------------------------
4560 (defun ti::keymap-put-map (map &optional func)
4561 "Put function `ignore' to a0 > x <128 key MAP, optionally put FUNC."
4563 (func (or func 'ignore)))
4565 (define-key map (char-to-string i) func)
4568 ;;; ----------------------------------------------------------------------
4569 ;;; - Mapping keysto functions easily.
4571 (defun ti::keymap-mapkeys (map-key-fun args)
4572 "Maps MAP-KEY-FUN to list of keys in ARGS.
4577 '([f1] 'hilit-rehighlight-buffer
4579 [f3] 'repeat-complex-command))"
4583 (len (length args)))
4584 (if (eq 0 (% len 2)) nil
4585 (error "args not paired"))
4587 (setq key (nth i args) func (nth (1+ i) args) i (+ 2 i) )
4588 (funcall map-key-fun key func))))
4591 ;;{{{ (T)ext properties, faces
4593 ;;; ........................................................... &faces ...
4595 ;;; ----------------------------------------------------------------------
4597 (defun ti::buffer-text-properties-wipe (&optional beg end)
4598 "Remove all, ie. literally all, text properten between BEG and END.
4599 BEG AND end defaults to whole buffer.
4600 Doesn't care about read only status of buffer."
4602 (let (buffer-read-only
4603 (inhibit-read-only t)) ;allow read-only prop wipe out
4604 (set-text-properties
4605 (or beg (point-min))
4606 (or end (point-max))
4609 ;;; ----------------------------------------------------------------------
4610 ;;; - During setting a different color to a face,
4611 ;;; the color may be occupied and emacs halts with message
4613 ;;; (error "X server cannot allocate color" "DarkSeaGreen3")
4615 ;;; - This function allows you to give several "try" choices,
4617 (defun ti::set-face-try-list (list face &optional attribute)
4618 "Try to assign color to face.
4619 The input is list of color names which are tried one by one.
4620 First one that succeeds is assigned. If color is occupied, tries
4621 next one. Doesn't signal any errors.
4625 LIST (\"color1\" \"color2\" ..) or single color string
4626 FACE symbol. E.g. 'region
4627 ATTRIBUTE symbol. Choices are 'fg and 'bg. Default is 'fg
4631 color color that was assigned
4632 nil all tries failed"
4635 (setq attribute 'fg))
4636 (dolist (color (ti::list-make list))
4637 (when (condition-case nil
4641 (set-face-foreground face color))
4643 (set-face-background face color)))
4649 ;; succesfull; stop the loop
4655 ;;{{{ misc: movement
4657 ;;; ############################################################ &Misc ###
4659 ;;; ----------------------------------------------------------------------
4661 (defsubst ti::buffer-forward-line (&optional count)
4662 "Move vertically lines down. If COUNT is negative, then up.
4664 `forward-line' moves point always to the beginning
4665 of next line, and the elisp manual says not to use `next-line' in
4668 This function behaves exactly as `next-line'. If the next line is shorter
4669 it moves to the end of line."
4670 ;; (interactive "P")
4671 (let* ((col (current-column)))
4672 (and (null count) (setq count 1)) ;No arg given
4673 (forward-line count)
4674 (move-to-column col)))
4677 ;;{{{ buffer: line handling , addings strings
4679 ;;; ......................................................... &m-lines ...
4681 ;;; ----------------------------------------------------------------------
4683 (defun ti::buffer-looking-at-one-space ()
4684 "Return non-nil if point is in the middle on one whitespcae.
4685 This is a position where there is only one tab or one space or point is
4686 followed by one newline. Similarly if point is at `point-min' and there is
4687 only one whitepace, or at `point-max' is preceded by one whitespace."
4688 (let* ((char-backward (if (not (bobp))
4690 (char-forward (if (not (eobp))
4694 ((and (null char-backward)
4695 (null char-forward))
4696 ;; BOBPEOBP ie. empty buffer.
4701 (and (not (string-match "[ \t\f\r\n]"
4702 (char-to-string char-backward)))
4703 (string-match "[ \t\f\r\n]"
4704 (char-to-string char-forward))
4705 ;; What is the next character?
4708 (not (string-match "[ \t\f\r\n]"
4709 (char-to-string (following-char)))))))
4713 (string-match "[ \t\f\r\n]"
4719 ;;; ----------------------------------------------------------------------
4721 (defun ti::buffer-surround-with-char (char)
4722 "Insert two same CHAR around a string near point.
4723 String is delimited by whitespace, although the function will do
4724 the right thing at beginning or end of a line, or of the buffer.
4725 If the char is one of a matching pair, do the right thing.
4726 Also makes a great gift."
4727 (interactive "cSurround with char: ")
4728 ;; hmm, ought to be able to do this with syntax tables?
4733 ((or (char= char ?{) (char= char ?}))
4736 ((or (char= char ?\() (char= char ?\)))
4739 ((or (char= char ?<) (char= char ?>))
4742 ((or (char= char ?`) (char= char ?'))
4745 ((or (char= char ?[) (char= char ?]))
4748 (re-search-backward "^\\|\\s-" (point-min))
4750 (re-search-forward "\\s-")
4751 (if (looking-at "\\s-") (re-search-forward "\\s-")))
4752 (insert-char begchar 1)
4753 (let ((opoint (point)))
4754 (if (re-search-forward "\\s-\\|\n" (point-max) t)
4756 (goto-char (point-max)))
4757 (insert-char endchar 1)
4758 (if (eq (point) (+ opoint 1))
4759 (forward-char -1)))))
4761 ;;; ----------------------------------------------------------------------
4763 (defun ti::buffer-fill-region-spaces (beg end &optional column)
4764 "Fill region BEG END with spaces until COLUMN or 80.
4765 In picture mode paste/copying rectangles,
4766 it easiest if the area has spaces in every row up till
4769 To return to 'ragged' text, use function `ti::buffer-trim-blanks'
4772 BEG beginning of area, always line beginning
4773 END end of area, always line end.
4774 COLUMN the fill column. Defaults to 79, because 80 would
4775 add annoying \\ marks at the end of line."
4776 (interactive "*r\nP")
4777 (let* ((column (or column 79))
4778 (spaces (make-string (+ 2 column) ?\ ))
4783 (narrow-to-region beg end)
4784 (untabify (point-min) (point-max)) ;very important !!
4787 (setq line (ti::read-current-line)
4791 nil ;we can't touch this
4793 (insert (substring spaces 1 add)))
4794 (forward-line 1)))))
4796 ;;; ----------------------------------------------------------------------
4797 ;;; - This nice and elegant solution to get quotes around the words,
4798 ;;; but someday it should be generalized to put ANYTHING around the word.
4800 (defun ti::buffer-quote-words-in-region (beg end)
4801 "This function quotes words in selected region BEG END."
4804 (while (< (point) end)
4806 (insert (prin1-to-string (current-kill 0)))
4807 (setq end (+ end 2))
4811 ;;; ----------------------------------------------------------------------
4812 ;;; - E.g. if you want to decide "fast filling", you could check if any line
4813 ;; is longer that fill-column.
4815 (defun ti::buffer-find-longer-line (beg end len)
4816 "Check BEG END if there exist line longer than LEN.
4819 point beginning of line
4823 (goto-char (min beg end))
4824 (while (and (null pos)
4826 (< (point) (max beg end)))
4828 (if (<= (current-column) len)
4830 (beginning-of-line) (setq pos (point)) )
4834 ;;; ----------------------------------------------------------------------
4836 (defun ti::buffer-scramble-region (beg end &optional char)
4837 "Scrables text BEG END with char so that it's not readable any more.
4838 Preserves words by substituting every [a-zA-Z] with optional CHAR."
4840 (let* ((ch (if char ;pick the scramble char
4841 (char-to-string char)
4844 (save-restriction ;preserve prev narrowing
4845 (narrow-to-region beg end)
4847 (ti::buffer-replace-regexp "[a-zA-Z]" 0 ch)))))
4849 ;;; ----------------------------------------------------------------------
4850 ;;; - This function requires user input when RE-LOOK is given
4851 ;;; - This is aimed for lisp programs
4853 (defun ti::buffer-add-string-region (beg end str &optional re-look)
4854 "Add to region BEG END STR and optionally to lines matching RE-LOOK.
4855 You might use this as intend-region by adding more spaces to any
4856 vertical position, but most likely this is best function for
4857 commenting arbitrary blocks of code.
4859 1) set mark to _exact_column_ where to add string
4860 2) move cursor to destination line, column does not matter.
4862 If you want to add string to specific lines only, supply
4863 rex when you are asked for 'look for rex'. Remember that this
4864 rex will be used from that mark column to the end of line, so whole line
4865 is not looked. Here is one example:
4877 ;;#; another triplet
4878 ^^^^^^^^^^^^^^^^^^^^ --> the REX match area, note not incl. leading!
4880 Note that the single ';' isn't matched, because the mark's column position
4885 Emacs 19.28 has almost similar function. Look
4886 `string-rectangle'. It does not overwrite existing text."
4887 (interactive "r\nsString to region :\nsLook for re :")
4890 (if (ti::nil-p re-look) ;reset
4893 nil ;pass, nothing given
4895 ;; Get true boundaries.
4897 (goto-char (min beg end)) (setq col (current-column))
4898 (setq beg (line-beginning-position))
4899 (goto-char (max beg end)) (setq end (line-end-position))
4901 (narrow-to-region beg end) (ti::pmin)
4903 (move-to-column col t)
4904 (setq look (if (and re-look
4905 (eq (current-column) col))
4906 (looking-at re-look)
4910 (forward-line 1)))))))
4914 ;;{{{ buffer: lists handling, sorting
4916 ;;; ----------------------------------------------------------------------
4917 ;;; - The default sort-regexp-fields is too limited and awkward to use.
4918 ;;; - This one offers easy interface to 'sort'
4920 (defun ti::buffer-sort-regexp-fields (list level re &optional numeric reverse case)
4921 "Sort LIST of strings at subexpression LEVEL of RE.
4922 Sort can optionally be NUMERIC, REVERSE or CASE sensitive.
4926 (let* ((clist (copy-list list))) ;sort modifies it otw.
4929 (lambda (l r &optional ret elt1 elt2)
4931 ((not case) ;not sensitive
4932 (setq l (downcase l) ;ignore case
4934 ;; read the maches from strings
4935 (setq elt1 (ti::string-match re level l)
4936 elt2 (ti::string-match re level r))
4938 ((not (and elt1 elt2)) ;make sure match happened
4943 (< (string-to-int elt2) (string-to-int elt1))
4944 (< (string-to-int elt1) (string-to-int elt2)))))
4949 (string< elt1 elt2)))))
4955 ;;{{{ misc: shell, exec, process
4957 ;;; ......................................................... &process ...
4958 ;;; - Current "misc" category
4960 ;;; ----------------------------------------------------------------------
4961 ;;; - This is great function to build up completions for login names...
4962 ;;; - I have 400 entries in passwd file and it's not very fast.
4963 ;;; - You Should call this only once with regexp "." and put all the entries
4964 ;;; into some variable. Use that variable for lookup.
4966 (defun ti::file-passwd-grep-user-alist (re &optional not-re passwd-alist)
4967 "Grep all login names, where person name match RE.
4968 The matches are gathered from `ti::var-passwd-buffer' and if it does not
4969 exist, error is signaled.
4971 If optional NOT-RE is string, it will be used after the RE match is done.
4972 It is used to exclude items.
4974 If PASSWD-ALIST is given it will be used instead to gather needed
4975 information. It should be alist int he form returned by function
4976 `ti::file-passwd-build-alist'
4979 ((login . user-name-entry) ..)"
4980 (let* ((passwd-buffer ti::var-passwd-buffer)
4981 ;; The name is 5th entry
4982 ;; neva:I5KJd2C33dtMg:418:200:Max Neva,Houston Texas ...
4983 (passwd-re "^\\([^:]+\\):[^:]+:[^:]+:[^:]+:\\([^:,]+\\)")
4990 ;; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ list ^^^
4991 ;; Hm, the loops are almost identical, but what the heck...
4993 (setq line (cdr (car passwd-alist)))
4994 ;; It's possible, that there is no "person" field, e.g.
4995 ;; "lp:*:9:7::/usr/spool/lp:/bin/sh"
4999 ;; It's quicker to test 2 at the same time, and only then decode
5000 ;; the field into parts
5001 (when (and (string-match re line)
5002 (string-match passwd-re line))
5003 (setq login (match-string 1 line))
5004 (setq person (match-string 2 line))
5005 (when (and login person)
5006 (if (or (not (stringp not-re))
5007 (and (stringp not-re)
5008 (not (string-match not-re person))))
5009 (push (cons login person) alist))))
5010 (pop passwd-alist)))
5012 ;; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ buffer ^^^
5013 (if (null (ti::set-buffer-safe passwd-buffer))
5014 (error "Passwd buffer does not exist"))
5015 (if (eq (point-min) (point-max))
5016 (error "Passwd buffer is empty."))
5019 (setq line (ti::read-current-line))
5020 (when (and (string-match re line)
5021 (looking-at passwd-re))
5022 (setq login (match-string 1))
5023 (setq person (match-string 2))
5025 (if (null (and login person))
5027 (if (or (not (stringp not-re))
5028 (and (stringp not-re)
5029 (not (string-match not-re person))))
5030 (push (cons login person) alist))))
5034 ;;; ----------------------------------------------------------------------
5035 ;;; E.g. in HP-UX the command is this
5036 ;;; (my-read-passwd-entry "jaalto" "ypcat passwd")
5038 (defun ti::file-passwd-read-entry (&optional user cmd)
5039 "Return USER's password entry using Shell CMD.
5041 If the password buffer's content is not empty, the CMD isn't called, instead
5042 the entry is searched from the buffer. This reduces overhead of calling
5043 processes every time function is invoked.
5046 `ti::var-passwd-buffer'"
5047 (let* ( ;; Permanent buffer, since launching process is expensive
5048 (user (or user (user-login-name)))
5049 (re (concat "^" user ":"))
5050 (buffer (get-buffer-create ti::var-passwd-buffer))
5053 (with-current-buffer buffer
5054 (when (eq (point-min) (point-max)) ;No entries yet
5056 (error "Need command to get the passwd file")
5058 (let ((list (split-string cmd)))
5059 (apply 'call-process
5066 (if (re-search-forward re nil t)
5067 (setq ret (ti::read-current-line)))))
5070 ;;; ----------------------------------------------------------------------
5072 (defun ti::file-passwd-build-alist (cmd)
5073 "Build assoc list out of passwd table using CMD.
5074 Please note, that building a list takes some time, so call this
5075 only once per program. The CMD must be a command to retrieve
5076 contents of passwd file.
5080 The performance of this function is not very good. Expect
5081 parsing 1000 users/15 seconds.
5085 ((login . full-passwd-entry) ..)"
5086 (let* ((passwd-buffer ti::var-passwd-buffer)
5090 ;; force loading passwd entries
5091 (ti::file-passwd-read-entry "SomeUser" cmd)
5092 (with-current-buffer passwd-buffer
5096 (setq line (buffer-substring
5097 (point) (progn (end-of-line) (point))))
5098 ;; password entry looks like this, sometimes there may be garbage
5099 ;; after shell command like these two grep notes.
5101 ;; grep: can't open a
5102 ;; grep: can't open tty
5104 ;; lm58817:x:23193:23193:Leena M{ki|:/home3/li7/lm58817:/bin/tcsh
5105 (when (setq login (ti::string-match "^[^:]+" 0 line))
5106 (setq alist (cons (cons login line) alist)))
5111 ;;{{{ misc: function
5113 ;;; ----------------------------------------------------------------------
5115 (defun ti::buffer-defun-function-name (&optional point)
5116 "Return possible function name.
5117 Starts searching backward form current or optional POINT.
5118 Be sure to be in right mode, so that right `beginning-of-defun' is used.
5120 In Lisp, the current function can be found only if it is left flushed.
5122 In C++, this will simply returns line portion, which it thinks
5123 contains function name.
5125 In Perl, it is supposed that word following \"sub\" is function name.
5133 (let* ((name (symbol-name major-mode))
5135 "def\\(un\\|subst\\|macro\\|advice\\|var\\|const\\)"
5136 "[ \t]+\\([^ \t]+\\)"))
5139 (setq line (ti::read-current-line))
5142 ;; Now comes fun part...Ugh!
5144 ((or (setq ret (ti::string-match lisp-re 2 line))
5145 (string-match "lisp" name))
5146 ;; This beginning-of-defun only finds only left
5151 (beginning-of-defun) (setq line (ti::read-current-line))
5152 (setq ret (ti::string-match lisp-re 2 line)))))
5154 ((or (string-match "CC" name)
5155 (string-match "C++" name))
5156 (beginning-of-defun)
5160 ;; pMscCg_c::DecodeV7
5164 ;; perAtom_c *pMscCg_c::DecodeV7
5169 (search-backward "(")
5171 (or (setq ret (ti::buffer-match "^[ \t]*\\([^ \t(]+\\)[ \t]*(" 1))
5172 (progn ;skip one line up
5174 (setq ret (ti::buffer-match "^[ \t]*\\([^\n(]+\\)" 1)))))
5176 ((and (string-match "perl" name)
5177 (re-search-backward "^[ \t]*sub[ \t]+\\([^ \t]+\\)" nil t))
5178 (setq ret (match-string 1)))))
5184 ;;; ############################################################ &File ###
5186 ;;; ----------------------------------------------------------------------
5188 (defsubst ti::file-days-old (file)
5189 "Calculate how many days old the FILE is. This is approximation."
5190 (let ((now (current-time))
5191 (file (nth 5 (file-attributes file))))
5192 (/ (ti::date-time-difference now file) 86400)))
5194 ;;; ----------------------------------------------------------------------
5196 (defun ti::file-touch (file)
5197 "Touch FILE by updating time stamp. FILE is created if needed.
5198 Note: the filename is handed to the shell binary `touch'. Make sure the
5199 filename is understood by shell and does not contain meta characters."
5200 (if (not (file-exists-p file))
5201 (with-temp-buffer (write-region (point) (point) file))
5202 (let* ((touch (or (get 'ti::file-touch 'touch-binary)
5203 (executable-find "touch")
5204 (error "`touch' binary not found."))))
5205 (put 'ti::file-touch 'touch-binary touch)
5206 (call-process touch nil nil nil (expand-file-name file)))))
5208 ;;; ----------------------------------------------------------------------
5210 (defun ti::file-ange-completed-message (&rest args)
5211 "Default message after file has been loaded. Ignore ARGS."
5212 (message "Ange-ftp bg completed"))
5214 ;;; ----------------------------------------------------------------------
5215 ;;; #todo: Not quite what I want...
5217 (defun ti::file-ange-status (ange-ref)
5218 "Return status on ANGE-REF ftp buffer.
5221 'no-ange if no ange buffer exists
5222 (..) some ange status values"
5223 (let* ((ret 'no-ange)
5233 (setq ange (ange-ftp-ftp-name ange-ref) ;crack addr
5237 ((setq buffer (ti::buffer-find-ange-buffer user host))
5238 (if (null buffer) (setq buffer buffer)) ;XEmacs 19.14 Bytecomp silencer
5239 ;; Create a new process if needed
5240 (setq proc (ange-ftp-get-process host user))
5241 ;; The status value is valid only when process finishes.
5243 (set-buffer (process-buffer proc))
5245 (setq ret ange-ftp-process-result
5246 line (ti::read-current-line)
5247 stat (ange-ftp-process-handle-line line proc)
5248 busy ange-ftp-process-busy)
5251 ;; ange-ftp-process-result-line = good
5252 ;; fatal, deletes process.
5253 (setq ret (list ret stat busy)))))
5256 ;;; ----------------------------------------------------------------------
5257 ;;; - an easy interface to ange ftp to get dingle file in bg.
5258 ;;; - this actually is a "macro" or toplevel func to the
5259 ;;; ti::file-ange-file-handle
5261 (defun ti::file-ange-download-file (ange-ref download-dir &optional not-bg)
5262 "Download single file pointed by ANGE-REF in background to the DOWNLOAD-DIR.
5266 ANGE-REF /login@site:/dir/dir/file.xx
5267 DOWNLOAD-DIR valid directory where to put the file.
5268 NOT-BG if non-nil the ftp is done in foregroung.
5272 nil if job is done in background
5273 status if in fg. Nil means failure."
5282 (setq ange (ange-ftp-ftp-name ange-ref) ;crack addr
5285 dir (file-name-directory (nth 2 ange))
5286 file (file-name-nondirectory (nth 2 ange))
5287 to-dir (expand-file-name download-dir))
5288 (ti::file-ange-file-handle 'get user host dir to-dir (list file) not-bg)))
5290 ;;; ----------------------------------------------------------------------
5291 ;;; - an easy interface to ange ftp to get/put wanted files
5292 ;;; #todo: sometimes ange hangs, rarely but... should check if
5293 ;;; process is live somehow?
5294 ;;; #todo: check that no process is going in the buffer, so that it's
5295 ;;; not called many times (overlapping).
5297 (defun ti::file-ange-file-handle
5298 (mode user host dir lcd file-list &optional not-bg msg-func)
5299 "Get files from remote or put files to remote site.
5303 All directory names must be absolute
5308 USER login name when logging to site
5310 DIR remote site directory
5311 LCD download local dir
5312 FILE-LIST files to get from/put to remote site
5313 NOT-BG should we wait until ange is done?
5314 nil = run on bg, non-nil = wait until done.
5315 MSG-FUNC function to call after download completes. Should
5316 contain &rest args parameter. See more in ange-ftp.el
5319 nil always if NOT-BG is nil
5320 status if NOT-BG is non-nil. Value nil means that session
5322 (let* ((func (or msg-func 'ti::file-ange-completed-message))
5334 (setq func 'ignore)) ;can't use any function for this...
5336 (error "What mode?")))
5337 (if (not (ti::listp file-list))
5338 (error "file-list must be LIST and _not_ empty"))
5339 ;; We need absolute directory names, because the FTP process
5340 ;; running does not understand anything else.
5341 (setq lcd (expand-file-name lcd))
5342 ;; Start FTP session if it does not exist
5344 (setq proc (ange-ftp-get-process host user))
5345 ;;; (setq M mode U user H host D dir L lcd F file-list P proc)
5346 ;; - Expand remote site's directory reference
5347 (setq dir (ange-ftp-real-file-name-as-directory
5348 (ange-ftp-expand-dir host user dir)))
5349 ;; Without this, the next command dies. This is already called in function
5350 ;; ange-ftp-get-process, but for some unknown reason it must be called
5351 ;; again to be sure: the hash mark size was sometimes nil
5352 (with-current-buffer (ange-ftp-ftp-process-buffer host user)
5353 (if (null ange-ftp-ascii-hash-mark-size)
5354 (setq ange-ftp-ascii-hash-mark-size 1024))
5355 (if (null ange-ftp-binary-hash-mark-size)
5356 (setq ange-ftp-binary-hash-mark-size 1024)))
5357 (ange-ftp-set-binary-mode host user)
5358 ;; - After this commands ANGE hangs quite often and never executes
5359 ;; the "raw" commands
5360 ;; - That's why we loop MAX-TRY times to start the
5362 (ange-ftp-send-cmd host user (list 'lcd lcd) "Setting lcd...")
5364 ;; CD command dies if it the directory is wrong
5366 ;; The socond command just makes sure the command was successfull.
5367 ;; I added this, because when connection was cloased and ange
5368 ;; opened the connection again, the CWD command didn't succeed
5369 ;; right away. We must wait here until it succeeds and only then
5370 ;; send the real put or get request.
5371 (ange-ftp-cd host user dir)
5373 (set-buffer (process-buffer proc))
5377 (ti::pmax) (forward-line -1)
5378 ;; ftp> 250 CWD command successful.
5379 (not (string-match "success" (ti::read-current-line))))
5382 (push mode file-list) ;command for ange
5384 (set-buffer (process-buffer proc))
5386 ;; Try sending untill the point moves... => process started
5387 (setq point (point) try 0)
5388 (while (and (eq point (point))
5390 ;;; (ti::d! (eq point (point)) point (point))
5391 (ange-ftp-raw-send-cmd
5393 (ti::list-to-string file-list)
5394 "ftp ..." ;message displayed during 0%..100%
5395 (list func) ;called after completion ?
5396 (not not-bg)) ;continue without wait
5399 ;; The status value is valid only when process finishes.
5402 (set-buffer (process-buffer proc))
5403 (setq ret ange-ftp-process-result)))
5406 ;;; ----------------------------------------------------------------------
5408 (defun ti::file-chmod-w-toggle (file)
5409 "Toggle read-only flag for FILE.
5410 If file does not exist, or is not owned by user this function does nothing.
5414 'w+ file made writable
5415 'w- file made read-only.
5416 nil file not processed."
5417 (let* ((file (expand-file-name file))
5419 (when (ti::file-modify-p file)
5420 (setq mode (ti::file-toggle-read-write (file-modes file)))
5421 (set-file-modes file mode)
5422 ;; return value , -r--r--r-- , 600 oct= 384 dec
5423 (if (= 0 (logand mode 128))
5427 ;;; ----------------------------------------------------------------------
5429 (defun ti::file-chmod-make-writable (file)
5430 "Make FILE writable."
5431 (set-file-modes file (ti::file-mode-make-writable (file-modes file))))
5433 ;;; ----------------------------------------------------------------------
5435 (defun ti::file-chmod-make-read-only (file)
5436 "Make FILE read only."
5437 (set-file-modes file (ti::file-mode-make-read-only (file-modes file))))
5439 ;;; ----------------------------------------------------------------------
5441 (defun ti::file-find-shadows (&optional path)
5442 "Find duplicate files along optional PATH, which defaults to `load-path'."
5444 (or path (setq path load-path))
5446 (let ((true-names (mapcar 'file-truename path))
5457 (if (member (car true-names) (cdr true-names))
5458 (setq reduds (1+ reduds))
5459 (setq dir (car path))
5460 (setq curr-files (if (file-accessible-directory-p dir)
5461 (directory-files dir nil ".\\.elc?$" t)))
5464 (message "Checking %d files in %s..." (length curr-files) dir))
5465 (setq files-seen-this-dir nil)
5467 (setq file (car curr-files))
5468 (setq file (substring
5469 file 0 (if (string= (substring file -1) "c") -4 -3)))
5470 (unless (member file files-seen-this-dir)
5471 (setq files-seen-this-dir (cons file files-seen-this-dir))
5472 (if (not (setq orig-dir (assoc file files)))
5473 (setq files (cons (list file dir) files))
5474 (if (null out-buffer)
5476 (setq out-buffer (get-buffer-create "*Shadows*"))
5477 (display-buffer out-buffer)
5478 (set-buffer out-buffer)
5480 ;; Do not print if directories are the same
5482 (setq d1 (file-name-as-directory (car (cdr orig-dir)))
5483 d2 (file-name-as-directory dir))
5484 (unless (string= d1 d2)
5486 (format "%s%s shadows\n%s%s\n\n" d1 file d2 file)))))
5487 (setq curr-files (cdr curr-files)))) ;; if
5488 (setq path (cdr path)
5489 true-names (cdr true-names)))
5493 (let ((n (/ (count-lines (point-min) (point-max)) 3)))
5494 (format "%d shadowing%s found" n (if (eq n 1) "" "s")))
5495 "No shadowings found")))
5497 (if (zerop reduds) ""
5498 (format " (skipped %d redundant entr%s in path)"
5499 reduds (if (eq reduds 1) "y" "ies"))))))
5502 ;;; ----------------------------------------------------------------------
5504 (defun ti::directory-part-last (dir)
5505 "Return last portion of DIR.
5506 Like ~/this/dir/ would return `dir'.
5507 for `dir/' return `dir'."
5508 (when (or (string-match "^.*[\\/]\\([^\\/]+\\)[\\/]?$" dir)
5509 (string-match "^\\([^\\/]+\\)[\\/]?$" dir))
5510 (match-string 1 dir)))
5512 ;;; ----------------------------------------------------------------------
5514 (defun ti::directory-unique-roots (path-list)
5515 "Return unique root directories of PATH-LIST.
5516 Non-strings or empty strings in PATH-LIST are ignored.
5518 For example for directories ~/elisp/packages and ~/elisp/packages/more
5519 the unique root is ~/elisp/packages."
5521 (dolist (path path-list)
5522 (when (and (stringp path)
5523 (not (ti::nil-p path)))
5524 (insert (expand-file-name path) "\n")))
5525 (sort-lines nil (point-min) (point-max))
5529 ;;; (pop-to-buffer (current-buffer)) (ti::d! 'starting)
5531 (setq line (ti::buffer-read-line))
5535 (delete-matching-lines (concat "^" (regexp-quote line)))))
5536 ;;; (ti::d! 'ok list)
5539 ;;; ----------------------------------------------------------------------
5540 ;;; (tinypath-subdirectory-list "~")
5542 (defun ti::directory-subdirectory-list (path)
5543 "Return all subdirectories under PATH."
5545 (dolist (elt (directory-files path 'absolute) )
5546 (when (and (not (string-match "\\.\\.?$" elt)) ;; skip . and ..
5547 (file-directory-p elt)) ;; take only directories
5551 ;;; ----------------------------------------------------------------------
5553 (defun ti::directory-recursive-do (root function)
5554 "Start at ROOT and call FUNCTION recursively in each ascended directory."
5555 (let* ((list (ti::directory-subdirectory-list root)))
5557 (funcall function root)
5559 (ti::directory-recursive-do path function)))))
5561 ;;; ----------------------------------------------------------------------
5563 (defun ti::directory-up (path)
5564 "Go one PATH directory level up.
5566 Cygwin hpath handling:
5568 /cygdrive/ => / May not be what you want
5569 /cygdrive/c/ => /cygdrive/c Can't go no more upward
5570 /cygdrive/c/tmp => /cygdrive/c
5574 c:/temp => d:/ Notice, cannot return \"d:\"
5578 /path1/path2 => /path1
5579 /path1/path2/ => /path1
5580 /path1/path2/file.txt => /path1/path2"
5582 ((string-match "^/$\\|^[a-z]:[\\/]?$" path)
5585 (if (string-match "[/\\]$" path)
5586 (setq path (ti::string-match "^\\(.*\\)[^\\/]+" 1 path)))
5587 ;; /cygdrive/c/ is already a root directory
5589 ((string-match "^\\(/cygdrive/.\\)/?$" path)
5590 (match-string 1 path))
5592 (setq path (file-name-directory path))
5593 ;; d:/temp => d:/ ,do not return "d:"
5594 (if (and (string-match "[/\\].+[/\\]" path)
5595 (string-match "^\\([a-z]:\\)?.+[^/\\]" path))
5596 (match-string 0 path)
5599 ;;; ----------------------------------------------------------------------
5601 (defun ti::directory-subdirs (dir)
5602 "Return directories under DIR."
5604 (when (file-directory-p dir)
5605 (dolist (elt (directory-files dir 'full))
5606 (if (file-directory-p elt)
5610 ;;; ----------------------------------------------------------------------
5612 (defun ti::directory-unix-man-path-root ()
5613 "Determine manual page root path. "
5615 (dolist (try '("/opt/local/man" ;HP-UX new
5616 "/usr/share/man" ;HP old
5617 "/usr/man")) ;Sun and Linux
5618 (if (ti::win32-cygwin-p)
5619 (setq try (w32-cygwin-path-to-dos try)))
5621 (file-directory-p try))
5624 ;;; ----------------------------------------------------------------------
5626 (defun ti::directory-files (dir re &optional absolute form not-re-form)
5627 "Return files from DIR.
5632 RE regexp for files to match
5633 ABSOLUTE flag, Return files as absolute names?
5634 FORM eval form, test each file with FORM instead of RE
5635 NOT-RE-FORM eval form, drop file if this evaluates to t
5639 ;; Get all filenames that aren't zipped, backups or objects.
5640 ;; The 'arg' will hold the filename
5642 (ti::directory-files dir re t nil '(string-match \"g?[Z~#o]$\" arg)))
5644 ;; Return only directory names
5646 (ti::directory-files dir \".\" 'absolute
5647 '(file-directory-p arg)
5648 '(string-match \"\\\\.\\\\.?$\" arg))
5652 list (file file file ..)"
5655 (directory-files dir absolute re))
5656 (when (or (null form) ;accept all
5657 (eval form)) ;accept only these
5658 (when (or (null not-re-form)
5659 (null (eval not-re-form)))
5663 ;;; ----------------------------------------------------------------------
5666 (defun ti::file-files-only (list &optional eval-form)
5667 "Return existing files. Drop directories from LIST of strings.
5668 Note: 200 files takes about 2-3 secs. If you supply EVAL-FORM, the item
5669 will be included if the form Return t. You can refer to current item
5674 LIST list of strings
5675 EVAL-FORM optional eval statement
5683 (and (file-exists-p arg)
5684 (not (file-directory-p arg))))
5688 ;;; ----------------------------------------------------------------------
5690 (defun ti::file-newer-exist (f1 f2)
5691 "Return file F1 or F2 which is newer. If only one of them exist, return it.
5695 nil none of them exist"
5697 ((and (file-exists-p f1)
5699 (if (file-newer-than-file-p f1 f2)
5708 ;;; ----------------------------------------------------------------------
5710 (defun ti::file-get-extension (file &optional mode)
5711 "Return FILE extension.
5712 If MODE is nil, then return nil if none exist,
5713 if MODE is non-nil, return empty string instead."
5717 ;;; (ti::d! (null file) (null (string-match "\\." file)))
5719 (null (string-match "\\." file)))
5721 (setq list (split-string file "[\.]"))
5722 (setq len (length list))
5724 (setq ext (car list)) ; first element
5725 (setq ext (nth (1- len) list)))) ; last element
5726 (if ext ext ;what to return?
5731 ;;; ----------------------------------------------------------------------
5733 (defun ti::file-path-and-line-info (path)
5734 "Return (PATH . LINE-NBR) if path is in format PATH:NBR."
5736 (when (string-match ":\\([0-9]+\\):?[ \t\f]*$" path)
5737 (setq line (string-to-int (match-string 1 path)))
5738 (setq path (ti::replace-match 0 "" path))
5741 ;;; ----------------------------------------------------------------------
5743 (defsubst ti::file-path-to-unix (path)
5744 "Convert PATH to Unix forward slash format."
5745 (replace-char-in-string ?/ ?\\ path))
5747 ;;; ----------------------------------------------------------------------
5749 (defsubst ti::file-path-to-msdos (path)
5750 "Convert PATH to MS-DOS backward slash format."
5751 (replace-char-in-string ?\\ ?/ path))
5753 ;;; ----------------------------------------------------------------------
5755 (defun ti::file-make-path (dir &optional file)
5756 "Make full path by combining DIR and FILE.
5757 In Win32, return backward slashed paths. Otherwise forward slashed
5760 DIR will always have trailing directory separator.
5761 You need to call this function if you pass a absolute path to
5762 external processes. Emacs in the other hand can handle both \\ and /
5764 (if (ti::emacs-type-win32-p)
5765 (replace-char-in-string
5766 ?\\ ?/ (concat (file-name-as-directory dir) (or file "")))
5767 (replace-char-in-string
5768 ?/ ?\\ (concat (file-name-as-directory dir) (or file "")))))
5770 ;;; ----------------------------------------------------------------------
5771 ;;; #defalias (defalias 'which 'ti::file-get-load-path)
5773 (defun ti::file-get-load-path (fn paths &optional all-paths verb)
5774 "Return full path name for FN accross the PATHS.
5777 FN filename to search
5778 PATHS list of path names
5779 ALL-PATHS return all matches.
5780 VERB verbose flag. Allows printing values in echo area
5785 str first match if all-paths is nil
5786 list list of matches along paths."
5788 (let* ((map (copy-keymap minibuffer-local-map))
5791 (define-key map "\t" 'lisp-complete-symbol)
5792 (define-key map "\C-m" 'exit-minibuffer)
5793 (setq var1 (read-from-minibuffer "sFile: "))
5794 (setq var2 (read-from-minibuffer "Lisp var: " "exec-path" map))
5795 (list var1 (eval (intern-soft var2)))))
5799 (when (stringp elt) ;you never know what's in there...
5800 (setq file (ti::file-make-path elt fn))
5801 (when (and (file-exists-p file)
5802 (not (file-directory-p file)))
5807 (if (and found all-paths) ;preserve order
5808 (setq found (nreverse found)))
5809 (if (and found verb)
5810 (message (prin1-to-string found)))
5813 ;;; ----------------------------------------------------------------------
5815 (defun ti::file-user-home ()
5816 "Try to guess user's home directory.
5819 /PATH/PATH/USER/ users home
5821 (let* ((usr (or (getenv "USER") (getenv "LOGNAME") ))
5822 (home (or (getenv "HOME") (getenv "home") ))
5823 (path (expand-file-name "~")))
5826 ((> (length home) 0) ;$HOME exist
5828 ((> (length usr) 0) ;users name exist
5831 ((executable-find "pwd") ;Win32 test
5832 ;; Try to get via 'pwd' process then.
5833 (call-process "pwd" nil (current-buffer) nil)
5835 (if (re-search-forward usr nil t)
5836 (setq path (buffer-substring (point-min) (match-end 0)))))
5837 ((executable-find "ls")
5838 ;; Failed ? try ls then...
5840 (call-process "ls" nil (current-buffer) nil)
5841 (if (re-search-forward usr nil t)
5842 (setq path (buffer-substring
5843 (point-min) (match-end 0)))))))))
5844 ;; make sure it has trailing "/"
5846 (setq path (ti::file-make-path path)))
5849 ;;; ----------------------------------------------------------------------
5850 ;;; You can use this in interactive command to build up a completion list:
5854 ;;; (list (completing-read
5855 ;;; "Visit file: " (ti::file-file-list load-path "\\.el$"))))
5856 ;;; (let ((pair (assoc emacs-file (ti::file-file-list load-path "\\.el$"))))
5858 ;;; (find-file (cdr pair))
5859 ;;; (find-file (expand-file-name emacs-file "~/emacs")))))
5861 (defun ti::file-file-list (dirs re)
5862 "Read DIRS and return assoc of files matching RE. (FILE FULL-PATH-FILE)."
5864 (and (stringp dirs) ;only one entry given ?
5865 (setq dirs (list dirs)))
5868 (append files (directory-files (car dirs) t re)))
5869 (setq dirs (cdr dirs)))
5873 (cons (file-name-nondirectory file) file))
5876 ;;; ----------------------------------------------------------------------
5878 (defun ti::file-complete-file-name (file-name &optional dir flist)
5879 "Given a FILE-NAME string return the completed file name.
5883 If FILE-NAME is invalid entry, signal no error and return nil
5884 If no DIR is not given, use FILE-NAME's directory.
5885 If no DIR nor FILE-NAME dir, use `default-directory'
5886 if non-nil flag FLIST, then return completed filename list
5890 DIR must end to a slash or otherwise it is considered partial
5896 list list of completions if FLIST is set.
5900 (ti::emacs-type-win32-p)
5901 (string-match "/cygdrive" file-name))
5905 (file (substitute-in-file-name file-name))
5906 (uncomplete (file-name-nondirectory file))
5909 (setq odir ;Save the original directory.
5910 (substring file-name 0 (- (length file-name) (length uncomplete))))
5912 (if (and (stringp odir)
5914 (string-match "^\\.\\." odir))
5915 (setq dir (format "%s%s" (file-name-as-directory dir) odir)))
5916 ;; expand-file-name dies if default-directory is nil
5920 (file-name-directory file-name)
5924 ;; if given impossible entry like "!@#!#"
5926 (file-name-all-completions uncomplete dir)))
5927 ;; Only one match in the list? voila!
5929 (eq 1 (length completed)))
5930 (setq completed (ti::file-name-forward-slashes (car completed))))
5932 ((and (stringp completed)
5933 (not (string= completed uncomplete)))
5934 (concat odir completed))
5935 ((and flist completed)
5938 ;;; ----------------------------------------------------------------------
5940 (defun ti::file-complete-file-name-word (&optional word no-msg)
5941 "Complete filename WORD at point.
5942 `default-directory' is used if no directory part in filename.
5943 See `ti::file-complete-file-name'.
5945 You can use this feature easily in Lisp interactive call.
5946 See macro `ti::file-complete-filename-minibuffer-macro' for more.
5948 NO-MSG if non-nil, do not flash possible choices at current point
5949 The `sit-for' command is used for displaying, so you can
5950 interrupt it by pressing any key."
5956 (ti::buffer-read-space-word))))
5958 (enable-recursive-minibuffers t)
5963 ;; expand-file-name dies if default-directory is nil
5964 (or default-directory
5965 (error "default-directory is nil !!"))
5966 (unless (ti::nil-p word)
5967 (setq word (ti::file-complete-file-name word nil 'list))
5968 (when (ti::listp word)
5969 (let ((alist (ti::list-to-assoc-menu word)))
5970 (when (stringp (setq tmp (try-completion oword alist)))
5972 ;; still completions left? Was this unique?
5973 all (all-completions word alist)))))
5974 (when (stringp word)
5975 (when (and (null no-msg)
5976 ;; This completion is not unique, so show all matches
5977 (string= oword word)
5979 (setq msg (format "%d: %s"
5981 (ti::list-to-string all)))
5984 (when (and (stringp word)
5985 (not (string= word oword)))
5986 (skip-chars-backward "^\n\t ")
5987 (let ((point (point)))
5988 (skip-chars-forward "^\n\t ")
5989 (delete-region point (point))
5990 (insert (ti::file-name-forward-slashes word)))))))
5992 ;;; ----------------------------------------------------------------------
5994 (put 'ti::file-complete-filename-minibuffer-macro 'lisp-indent-function 0)
5995 (defmacro ti::file-complete-filename-minibuffer-macro (&rest body)
5996 "Complete filename in minibuffer and do BODY.
5997 Use variable 'map' to pass map to `read-from-minibuffer' function.
6001 (ti::file-complete-filename-minibuffer-macro
6002 (read-from-minibuffer \"test\" nil map))
6006 (defun my-example (string file-list)
6007 \"FILE-LIST is string. Allow completion on words\"
6010 (read-from-minibuffer \"Gimme string: \")
6012 (ti::file-complete-filename-minibuffer-macro
6013 (read-from-minibuffer \"Gimme file-list: \" nil map)))))
6014 (list string file-list))
6016 (setq result (call-interactively 'my-example)) \"test\" RET <files> RET
6018 --> (\"test\" (\"~/\" \"~/bin\" \"~/exe/\"))"
6020 (let* ((map (copy-keymap minibuffer-local-map)))
6021 ;; this event also exists for tab
6022 (define-key map [kp-tab] 'ti::file-complete-file-name-word)
6023 (define-key map [tab] 'ti::file-complete-file-name-word)
6024 (define-key map "\t" 'ti::file-complete-file-name-word)
6027 ;;; ----------------------------------------------------------------------
6029 (defun ti::file-read-file-list (&optional message)
6030 "Read file or directory list as one string, and return it as LIST.
6031 Display optional MESSAGE, otherwise use default message.
6033 Filesnames can be completed with tab. `default-directory' is used for
6034 files that do not have directory part. Make sure default dir has ending
6039 (setq files (mapcar 'expand-file-name (ti::file-read-file-list)))
6043 (ELT ELT ..) with `default-directory'
6048 (ti::file-complete-filename-minibuffer-macro
6049 (read-from-minibuffer
6052 ;; limit the directory name
6053 (ti::string-right default-directory 10)))
6055 (unless (ti::nil-p str) ;not empty?
6056 (dolist (str (split-string str " "))
6057 (if (not (string-match "/" str))
6058 (setq str (concat default-directory str)))
6064 ;;{{{ Network streams
6066 ;;; ......................................................... &network ...
6068 ;;; ----------------------------------------------------------------------
6070 (defun ti::process-finger-error (&optional buffer)
6071 "Read BUFFER containing a finger response after `ti::process-finger'.
6072 If there is an error, then return possible error cause string.
6075 string cause of error
6078 (with-current-buffer (or buffer (current-buffer))
6080 (when (re-search-forward "unknown host:" nil t)
6081 (setq ret (ti::read-current-line))))
6084 ;;; ----------------------------------------------------------------------
6085 ;;; Original function in mc-pgp.el:mc-pgp-fetch-from-finger
6087 (defun ti::process-finger (email &optional port timeout buffer verb)
6088 "Finger EMAIL on PORT with TIMEOUT.
6089 The output is clered from possible ^M characters.
6093 EMAIL email address foo@site.com
6096 BUFFER where to store result, default is *finger tmp*
6097 VERB print verbose messages
6101 string error while doing opening network stream
6103 (interactive "sFiger email: ")
6108 (setq verb (or verb (interactive-p))
6110 timeout (or timeout 25))
6111 (if (not (string-match "^\\([^ \t]+\\)@\\([^[ \t]+\\)" email))
6112 (error "Need email address foo@site.com '%s'" email)
6113 (setq user (match-string 1 email)
6114 host (match-string 2 email))
6118 (if verb (message "Fingering %s ..." email))
6119 (setq buffer (or buffer (ti::temp-buffer "*finger tmp*" 'clear)))
6120 ;;; (pop-to-buffer buffer) (ti::d! "going finger....")
6121 (condition-case error
6125 (open-network-stream "*finger*" buffer host port))
6126 (process-send-string
6127 connection (concat "/W " user "\r\n"))
6128 (while (and (memq (process-status connection) '(open))
6129 (accept-process-output connection timeout))))
6131 ;; '(file-error "connection refused "connection failed" ..)
6132 (setq ret (ti::list-to-string (cdr error))))
6134 (setq ret (ti::list-to-string (cdr error)))))
6135 (if connection (delete-process connection))
6136 ;; Strip Ctrl-M marks
6137 (with-current-buffer buffer
6138 (ti::buffer-lf-to-crlf 'dos2unix)))))
6140 (message "Fingering %s ...done" email))
6142 (pop-to-buffer buffer))
6146 ;;; ----------------------------------------------------------------------
6148 (defun ti::process-http-request (command &optional port timeout buffer verb)
6149 "Send http COMMAND i.e. URL request.
6150 Control character C-m is removed from response.
6152 If COMMAND includes port number, e.g.:
6154 http://www-swiss.ai.mit.edu:80/htbin/pks-extract-key.pl
6156 This is actually intepreted as
6158 http = www-swiss.ai.mit.edu
6160 command = /htbin/pks-extract-key.pl
6164 COMMAND http command string
6166 TIMEOUT default is 60
6167 BUFFER where to store result, default is *finger tmp*
6168 VERB print verbose messages
6172 '(buffer-pointer error-string)
6174 error-string network stream error message.
6175 buffer HTTP response."
6176 (interactive "sHttp request: ")
6180 (setq verb (or verb (interactive-p))
6182 timeout (or timeout 60))
6183 (if (not (string-match "^http://\\([^/]+\\)\\(/.*\\)" command))
6184 (error "Must be _http_ request '%s'" command)
6185 (setq host (match-string 1 command)
6186 command (match-string 2 command))
6187 (if (string-match "\\(.*\\):\\([0-9]+\\)" host)
6188 (setq port (string-to-int (match-string 2 host))
6189 host (match-string 1 host))))
6190 ;;; (ti::d!! "\n" command "HOST" host "PORT" port "TIME" timeout buffer)
6195 (message "Http %s ..." host))
6196 (setq buffer (or buffer (ti::temp-buffer "*http tmp*" 'clear)))
6197 ;;; (ti::d! host port command "sending http....")
6198 (condition-case error
6202 (open-network-stream "*http*" buffer host port))
6203 (process-send-string
6207 " HTTP/1.0\r\n\r\n"))
6208 (while (and (eq 'open (process-status connection))
6209 (accept-process-output connection timeout))))
6211 ;; '(file-error "connection refused "connection failed" ..)
6212 (setq ret (ti::list-to-string (cdr error))))
6214 (setq ret (ti::list-to-string (cdr error))))))
6215 ;; ................................................... cleanup ...
6217 (delete-process connection))
6218 ;; Strip Ctrl-M marks
6219 (with-current-buffer buffer
6220 (ti::buffer-lf-to-crlf 'dos2unix))))
6222 (message "Http %s ...done" host))
6224 (pop-to-buffer buffer))
6228 ;;{{{ shell: zipping
6230 ;;; ....................................................... &shell-zip ...
6232 ;;; ----------------------------------------------------------------------
6234 (defun ti::process-uname ()
6236 (let* ((uname (executable-find "uname")))
6239 (call-process uname nil (current-buffer) nil "-a")
6242 ;;; ----------------------------------------------------------------------
6247 (defun ti::process-zip (zip-file files &optional zip-cmd)
6248 "Achive to ZIP-FILE. FILES is list (file file ..).
6249 The ZIP-CMD defaults to \"zip -9 -q\",
6250 Command will not return until the process has finished."
6251 (let* ((zcmd (or zip-cmd "zip -9 -q "))
6252 (shell-buffer (get-buffer-create "*Shell output*"))
6253 (flist (ti::list-join files))
6254 (cmd (concat zcmd " " zip-file " " flist)))
6255 (call-process cmd nil shell-buffer)
6257 (display-buffer shell-buffer))
6260 ;;; ----------------------------------------------------------------------
6262 (defun ti::process-zip-view-command (file &optional buffer nice zip-cmd verb)
6263 "Insert zip file listing to point.
6268 BUFFER defaults to current buffer
6269 NICE if non-nil, insert file name and empty lines around listing.
6270 ZIP-CMD defaults to 'unzip -v %s'
6275 nil no action [file not exist ...]
6276 nbr shell return code"
6277 (interactive "fTar file: ")
6278 (let* ((cmd (or zip-cmd "unzip -v %s")))
6280 (if (not (and (stringp file)
6281 (file-exists-p file)))
6282 (error "Invalid file argument")
6284 (insert "file " (file-name-nondirectory file) ":\n"))
6285 (call-process cmd nil (or buffer (current-buffer)) nil
6286 (expand-file-name file))
6290 ;;; ----------------------------------------------------------------------
6292 (defun ti::process-tar-zip-view-maybe-command (file)
6293 "If FILE is zip/tar then insert listing to current point."
6295 ((string-match "\\.tar$\\|\\.tar.gz$\\|\\.tgz$" file)
6296 (ti::process-tar-view-command file nil 'nice))
6297 ((string-match "\\.zip$" file)
6298 (ti::process-zip-view-command file nil 'nice))))
6300 ;;; ----------------------------------------------------------------------
6302 (put 'ti::process-perl-process-environment-macro 'lisp-indent-function 1)
6303 (put 'ti::process-perl-process-environment-macro 'edebug-form-spec '(body))
6304 (defmacro ti::process-perl-process-environment-macro (perl-type &rest body)
6305 "Check PERL-TYPE and run BODY in correct Win32/Cygwin environment.
6306 Fixe TEMP variable during the process call.
6310 PERL-TYPE 'perl 'win32-cygwin 'win32-activestate
6313 (let ((process-environment process-environment) ;; Make a local copy
6315 (dolist (elt process-environment)
6317 ((string-match "^TEMP=\\(.*\\)" elt)
6318 (let* ((tmp-dir (match-string 1 elt))
6319 (dir (if (and (stringp tmp-dir)
6320 (file-directory-p tmp-dir))
6321 (expand-file-name tmp-dir))))
6323 ((and (ti::win32-shell-p)
6324 ;; c:\temp or \\server\temp
6325 (not (string-match "=[a-z]:[\\]\\|=[\\][\\][a-z]" elt)))
6326 (if (file-directory-p "C:/TEMP")
6327 (push "TEMP=C:\\TEMP" new)
6328 (push "TEMP=C:\\" new)))
6329 ((and (string-match "[\\]\\|[a-z]:" tmp-dir) ;; Dos path
6330 (not (eq perl-type 'win32-activestate)))
6331 ;; Path must be in Unix format
6332 (let* ((path (if dir
6333 (w32-cygwin-dos-path-to-cygwin dir)
6335 (env (format "PATH=%s" path)))
6339 ((string-match "^PAGER=" elt)) ;; Delete this
6342 (setq process-environment new)
6345 ;;; ----------------------------------------------------------------------
6347 (defun ti::process-perl-version (&optional binary)
6348 "Check type of perl BINARY.
6352 (VERSION TYPE PATH OUTPUT)
6354 VERSION Version number from command line option -version
6355 TYPE is 'win32-activestate 'win32-cygwin or 'perl
6356 PATH Path to the BINARY or `perl'.
6357 OUTPUT Whole output of -v."
6358 (let* ((perl (if binary
6359 (executable-find binary)
6360 (executable-find "perl")))
6371 (setq string (buffer-string)))
6374 ((string-match "cygwin" string)
6376 ((string-match "activestate" string)
6378 ((not (ti::nil-p string))
6381 (error "Unknown perl type: %s" string))))
6382 ;; This is perl, v5.6.1 built for cygwin-multi
6384 "This[ \t]+is[ \t]+perl[ ,v\t]+\\([0-9.]+\\)"
6386 (setq version (match-string 1 string)))
6387 (list version type perl string))))
6389 ;;; ----------------------------------------------------------------------
6391 (defun ti::process-java-version (&optional binary)
6392 "Return java BINARY type and version number.
6396 (VERSION TYPE PATH FULL)
6398 VERSION Version number from command line option -version
6399 TYPE is 'sun or 'gcc or any other known Java vendor.
6400 PATH Path to the BINARY or `java'.
6401 FULL Whole output of -version."
6403 (let* ((java (executable-find (or binary "java")))
6407 ;; Under Debian, `call-process' will hang during
6408 ;; call to /usr/bin/java, which is a symlink
6410 (file-symlink-p java))
6411 (message "TinyLib: %s is symlink, cannot get version." java)
6414 ;; #todo: gcj Java version?
6421 (setq string (buffer-string)))
6423 ;; Java HotSpot(TM) Client VM (build 1.3.0_02, mixed mode)
6424 (or (string-match "build[ \t]+\\([0-9_.]+\\)" string)
6427 ;; java version "1.3.1"
6428 ;; Java(TM) 2 Runtime Environment, Standard Edition \
6429 ;; (build Blackdown-1.3.1-02b-FCS)
6430 (string-match "java +version +\"\\([0-9][0-9.]+\\)" string))
6431 (setq version (match-string 1 string)))
6433 ;; Java(TM) 2 Runtime Environment, Standard Edition (build 1.3.0_02)
6434 ((string-match "Java(TM)[ \t]+[0-9]" string)
6438 (list version type java string))))
6443 ;;; ----------------------------------------------------------------------
6445 (defun ti::process-tar-view-command (file &optional buffer nice verb test)
6446 "Insert tar file listing to point.
6451 BUFFER default to current buffer
6452 NICE if non-nil, insert file name and empty lines around listing.
6454 TEST Do not execute command. Print what would happen.
6458 nil no action [file not exist ...]
6459 nbr shell return code"
6460 (interactive "fTar file: ")
6462 ((string-match "\\.tar$" file)
6464 ((string-match "\\.tar\\.gz$" file)
6465 "gzip -d -c %s |tar -tvf -")
6466 ;; don't know this currently ...
6467 ((string-match "\\.tgz$" file)
6471 ;; Default tar switches:
6472 ;; -t ,List the name
6474 ;; -f ,next arg argument as the name of the archive (file)
6479 (file-exists-p file)
6481 (or (file-exists-p "/hp-ux/")
6482 (file-exists-p "/vol/")
6486 Can't guess tar command, try using default %s ? " def))))
6489 (insert "file " (file-name-nondirectory file) ":\n"))
6490 (call-process cmd nil (or buffer (current-buffer)) nil
6491 (expand-file-name file))
6492 (if nice (insert "\n")))))
6494 ;;; ----------------------------------------------------------------------
6496 (defun ti::process-tar-read-listing-forward ()
6497 "Read all tar filenames from current line forward.
6498 The point is not preserved. The tar listing looks like:
6500 r-xr-xr-x 240/222 4269 Feb 3 09:25 1997 aa.cc
6501 r-xr-xr-x 240/222 41515 Feb 3 09:40 1997 bb.cc
6502 r-xr-xr-x 240/222 3013 Feb 3 09:40 1997 dd.cc
6506 -r--r--r-- foo/bar 14764 1998-06-22 15:05:55 file.txt
6510 '((FILE SIZE PERMISSIONS) ..)"
6512 "^\\([drwx-]+\\)[ \t]+[0-9A-Za-z_]+/[0-9A-Za-z_]+"
6513 "[ \t]+\\([0-9]+\\)[ \t]+.*[0-9]:[0-9]+[ \t]+"
6517 (when (or (looking-at re)
6518 (re-search-forward re nil t))
6520 (while (and (looking-at re)
6522 (push (list (match-string 3) (match-string 2) (match-string 1)) list)
6527 ;;{{{ Reading lines, passwords
6529 ;;; ----------------------------------------------------------------------
6531 (defun ti::query-read-input-invisible ()
6532 "Read keyboard input. If user presses ESC, the asking is interrupted.
6536 (let* ((echo-keystrokes 0) ;prevent showing
6539 (while (not (ti::char-in-list-case ch '(?\n ?\C-m ?\e)))
6541 ((ti::char-in-list-case ch '(?\b ?\177))
6542 (if (eq 0 (length str))
6544 (setq str (substring str 0 (1- (length str)))) ))
6546 (setq str (concat str (char-to-string ch))) ))
6547 (setq ch (ti::read-char-safe-until)))
6552 ;;; ----------------------------------------------------------------------
6554 (defun ti::query-read-input-as-password (&optional prompt max echo-char)
6555 "Return read password using PROMPT, MAX chacters with ECHO-CHAR.
6556 If user presses ESC, return nil."
6558 (prompt (or prompt ""))
6559 (cursor-in-echo-area nil)
6560 (max (or max 80)) ;maximum string
6562 (make-string (+ max 2) echo-char )
6563 (make-string (+ max 2) ?* )))
6568 (while (not (ti::char-in-list-case ch '(?\n ?\C-m ?\e)))
6570 ((or (ti::char-in-list-case ch '(?\b ?\177)))
6571 (setq len (length str))
6573 (setq str (substring str 0 (1- len)))) )
6575 (if (>= (length str) max)
6576 (beep) ;signal error
6577 (setq str (concat str (char-to-string ch)))
6578 (message (substring bar 0 (length str)))) ))
6579 (setq ch (ti::read-char-safe-until
6580 (concat prompt (substring bar 0 (length str))))))
6588 ;;{{{ misc: advice control
6590 ;;; ----------------------------------------------------------------------
6592 (defun ti::advice-control
6593 (single-or-list regexp &optional disable verb msg)
6594 "Enables/disable SINGLE-OR-LIST of adviced functions that match REGEXP.
6595 Signals no errors, even if function in LIST is not adviced.
6596 All advice classes ['any] are ena/disabled for REGEXP.
6600 SINGLE-OR-LIST function of list of functions.
6601 REGEXP advice name regexp. Should normally have ^ anchor
6602 DISABLE flag, if non-nil then disable
6603 VERB enable verbose messages
6604 MSG display this message + on/off indication"
6605 (dolist (func (ti::list-make single-or-list))
6608 (ad-disable-advice func 'any regexp)
6609 (ad-enable-advice func 'any regexp))
6611 (ad-activate func)))
6615 (or msg "advice(s): ")
6616 (if disable "off" "on")))))
6620 ;;{{{ misc: -- packaging, install, reports
6622 ;;; ..................................................... &bug-reports ...
6623 ;;; - Take a look at lisp-mnt.el if you're writing
6624 ;;; your own packages.
6626 ;;; ----------------------------------------------------------------------
6627 ;;; #defalias (defalias 'package-feedback 'ti::package-feedback)
6629 (defun ti::package-submit-feedback (lib)
6630 "Composes feedback report with lisp-mnt.el conmoncerning Lisp file LIB.
6631 Make sure the file beeing reported is valid according to
6632 lisp-mnt's command `lm-verify'."
6633 (interactive "sSend mail regarding file: ")
6639 (or (locate-library lib)
6641 (setq lib (concat lib ".gz"))
6642 (locate-library lib))))
6644 (set-buffer (setq buffer (ti::find-file-literally file)))
6645 (setq version (ti::vc-rcs-buffer-version))
6647 (format "%s %s Feedback"
6649 (file-name-nondirectory file)))
6650 (kill-buffer buffer))
6652 (error (concat "No such file in load path: " lib))))))
6654 ;;; ----------------------------------------------------------------------
6655 ;;; - See package tinydiff.el and function tdi-feedback there if you
6656 ;;; are still curious how to use this function
6658 (defun ti::package-submit-bug-report
6659 (lib id var-list &optional verb elts)
6660 "Submit bug report with reporter.
6662 PRECONDITIONS before using this function
6664 1. The file must be in version control and it must have the \"\$ Id \$\" identifier
6665 stored into variable. Like the following:
6667 (defconst tinylib-version-id
6668 \"\$ Id: tinylib.el,v 1.18 1996/01/24 09:44:48 jaalto Exp jaalto \$\"
6669 \"Latest modification time and version number.\")
6671 2. The package must be valid according to lisp-mnt.el's command
6672 `lm-verify' so that the \"maintainer\" information can be extracted.
6673 This means that you file must have header like this:
6675 ;; Maintainer: Foo Bar <foo@example.com>
6679 LIB filename without path. E.g. \"tinylib.el\"
6680 ID the RCS Id string
6681 VAR-LIST list of variables to get from package. Like '(var1 var2)
6682 VERB Verbose messages and questions.
6683 ELTS a) Buffer to included in report.
6684 b) If this is functionp, then function must return a
6685 string or buffer pointer to include.
6686 c) if this is boundp, the value is taken as buffer
6695 (or (car-safe (ti::package-get-header lib "maintainer")) ""))
6696 (setq list (split-string id " "))
6697 (setq subj (concat (nth 2 list) " " (nth 1 list))) ;; name && version
6698 ;; ................................................... compose mail ...
6699 (when (or (null verb)
6700 (y-or-n-p "Do you really want to submit a report? "))
6701 (reporter-submit-bug-report
6707 ;; ............................................... insert content ...
6713 (dolist (buffer elts)
6717 ;; .............................................. detect type ...
6720 (setq status (get-buffer buffer)))
6721 ((memq buffer '(nil t))) ;; Ignore
6722 ((and (symbolp buffer)
6724 (setq buffer (symbol-value buffer))
6725 (if (stringp buffer)
6726 (setq status (get-buffer buffer))
6727 (message "TinyLib: bug report ERROR. Malformed syntax %s"
6728 (prin1-to-string buffer))
6731 (setq function buffer)
6732 (setq status (funcall function))
6737 (setq buffer status)
6740 (when (and (interactive-p)
6743 (y-or-n-p (format "Buffer `%s' missing, continue? Are you sure? "
6744 (prin1-to-string buffer)))
6746 ;; ................................................. insert ...
6750 (buffer-name buffer))
6754 (symbol-name function))))
6755 (setq len (- 70 (length name)))
6756 (insert "\n\n[" name "] " (make-string len ?= ) "\n\n")
6757 (setq len (buffer-size))
6760 (insert-buffer buffer))
6761 ;; `insert-buffer' does not put point after insert,
6762 ;; go there manually
6763 (when (> (buffer-size) len)
6764 (forward-char (- (buffer-size) len)))))))
6765 ;; ............................................... position point ...
6767 (if (re-search-forward "Subject: *" nil t)
6769 (re-search-forward "Hi,\n"))))
6771 ;;; ----------------------------------------------------------------------
6773 (defun ti::package-version-info (lib &optional arg)
6774 "Gets package information and prints it to another buffer.
6775 The LIB is searched along 'load-path'.
6779 The file must be valid according to lisp-mnt.el::lm-verify
6783 You can complete the filename with TAB key
6787 LIB filename with .el added
6788 ARG prefix arg, print the versionin info in mode-line
6789 instead of creating full version buffer."
6794 (ti::file-complete-filename-minibuffer-macro
6795 (read-from-minibuffer
6796 (format "[%s] Version info for library: " default-directory)
6800 (setq file file)) ;XEmacs 19.14 bytecompiler silencer
6801 ;; Make sure there is .el
6803 (ti::string-verify-ends file ".el")
6804 current-prefix-arg)))
6813 lm-last-modified-date
6820 (or (locate-library lib)
6822 (setq lib (concat lib ".gz"))
6823 (locate-library lib))))
6827 (set-buffer (setq buffer (ti::find-file-literally file)))
6828 (setq rcs-id (or (ti::vc-rcs-str-find-buffer "Id") "<no rcs id>"))
6829 (kill-buffer buffer)
6830 (ti::read-char-safe-until rcs-id))
6833 (setq out (ti::temp-buffer "*version*" 'clear))
6834 ;; Now get the information from file with lisp-mnt.el
6835 (with-current-buffer (setq buffer (ti::find-file-literally file))
6837 lm-version (lm-version)
6838 lm-summary (lm-summary)
6839 lm-maintainer (lm-maintainer)
6840 lm-creation-date (lm-creation-date)
6841 lm-last-modified-date (lm-last-modified-date)
6842 lm-commentary (lm-commentary)
6843 rcs-id (ti::vc-rcs-str-find-buffer "Id")))
6844 (when (and (stringp lm-last-modified-date)
6845 (eq 3 (length (setq tmp (split-string lm-last-modified-date))))
6846 (eq 3 (length (nth 1 tmp))))
6847 ;; Convert "16 Feb 2000" --> to ISO 8601 Date
6848 (setq lm-last-modified-date
6851 (ti::month-to-0number (nth 1 tmp))
6853 (kill-buffer buffer)
6854 (setq maintainer-name
6855 (if (not (null lm-maintainer))
6856 (or (car-safe lm-maintainer) "<name not known>")
6857 "<name not known>"))
6858 (setq maintainer-email
6859 (if (not (null lm-maintainer))
6860 (or (cdr-safe lm-maintainer) "no email info")
6862 (switch-to-buffer-other-window out)
6864 lib " -- " (or lm-summary "<no info>") "\n\n"
6865 "Created : " (or lm-creation-date "<no info>") "\n"
6866 "Last modified: " (or lm-last-modified-date "<no info>") "\n"
6867 "Maintainer : " maintainer-name " <" (or maintainer-email "") ">\n"
6868 "Version : " (or lm-version "<no info>") "\n"
6870 (or lm-commentary "<no commentary found>"))
6872 (ti::pmin) (ti::buffer-replace-regexp "^;;;" 0 " ")
6873 (ti::pmin) (ti::buffer-replace-regexp "^;;" 0 " ")
6874 (ti::pmin) (ti::buffer-lf-to-crlf 'dos2unix 'force)
6877 (error (concat "No such file in load path: " lib))))))
6879 ;;; ----------------------------------------------------------------------
6882 (defun ti::package-get-header (lib header-list)
6883 "Get standard header information: e.g. maintainer, version, author.
6884 The valid syntax of these headers is defined in lisp-mnt.el.
6885 Make sure the file being visited can be run with lisp-mnt's
6886 command `lm-verify'.
6890 LIB the filename of the package, including \".el\"
6891 HEADER-LIST string or list of strings. E.g. '(\"maintainer\")
6895 list notice that empty hits are stored: '(nil nil ..)
6897 (let ((header-list (ti::list-make header-list))
6903 ((setq file (locate-library lib))
6905 (unwind-protect ;make sure file is removed
6907 (set-buffer (setq buffer (ti::find-file-literally file)))
6911 (setq elt (lm-header header))
6912 (if elt ;did we find any ?
6913 (setq hit t)) ;raise flag
6916 ;; Kill the file no matter what happens.
6917 (kill-buffer buffer)))
6919 (error (concat "No such file in load path: " lib))))
6920 (if (null hit) ;if no hits, clear the ret value
6924 ;;; ......................................................... &package ...
6925 ;;; - Here is some special functions. When you insert some example to
6926 ;;; your package, you can convert functions and text directly to
6927 ;;; "poor man's shar" format :-)
6928 ;;; - With function ti::package-make-mode-magic, you just
6930 ;;; 1. Be in lisp mode
6931 ;;; 2. Select example area to be inserted into somewhere
6932 ;;; 3. call the functions --> The result is inserted into registed
6933 ;;; 4. Go to package buffer and insert the register contents there.
6935 ;;; - Likewise the user can rip these "shar" examples with function
6936 ;;; ti::package-rip-magic
6938 ;;; 1. Select area and call the function. --> examples in register
6939 ;;; 2. Put them into your .emacs or another favourite file.
6941 ;;; - Use similar bindings
6942 ;;; (global-set-key "\C-cp" 'ti::package-make-mode-magic)
6943 ;;; (global-set-key "\C-cP" 'ti::package-rip-magic)
6945 ;;; ----------------------------------------------------------------------
6947 (defun ti::package-install-example (lib &optional re)
6948 "Install example setup for you from LIB.
6949 The LIB must be normal source file name ending in '.el'.
6950 Function tries to find $PackageInstallRe: 'REGEXP' $
6951 line which has the installation code chars in the surrounding
6952 quotes. The common practise is to have '^[ \t]*;;+[*]' for Lisp.
6953 If that regexp is followed by char '_' it means that the line is left empty.
6955 If you supply RE, it must have match in LEVEL 1.
6959 (interactive "sLibrary: ")
6960 (let* ((tmp "*ti::pkg*")
6961 (file (locate-library lib))
6962 (verb (interactive-p))
6963 ;; There has to be " " after the ":" otherwise it's not
6964 ;; rcs ident(1) compatible. Also before the last $ ,
6965 ;; there must be space.
6966 (re (or re "[$]PackageInstallRe: [ \t]*'\\(.*\\)' [$]"))
6972 (null (file-readable-p file)))
6973 (error (concat "Cannot locate/read " lib " in load-path: " file))
6974 (setq bp (ti::temp-buffer tmp 'clear))
6975 (with-current-buffer bp
6976 (insert-file-contents file)
6978 (if (or (null (re-search-forward re nil t))
6979 (null (match-end 1)))
6982 (error (concat "Cannot find install regexp: " re)))
6983 (setq comment-re (match-string 1)) ;read match in level 1
6984 (if (ti::nil-p comment-re)
6985 (error (concat "Level 1 mismatch_" (match-string 0) "_" re)))
6986 (save-excursion (setq id (ti::vc-rcs-str-find "Id" )))
6987 (ti::package-rip comment-re empty-line-ch (point-min) (point-max) )
6989 ;; And final touch, add version id if it existed.
6991 (insert (concat ";; No rcs id found.\n\n"))
6992 (insert (concat ";; " id "\n\n")))
6993 ;; Show contents if user called interactively.
6996 (message "Automatic install done.")))))
6999 ;;; ----------------------------------------------------------------------
7001 (defun ti::package-rip (re ch &optional beg end)
7002 "Delete section of commented text, so that only code remains.
7003 The installed code portion should have RE at front of each line.
7005 RE must have anchor ^ and CH must have some magic char to
7006 mean empty line. like RE = '^;;+[*]' and CH = '_':
7008 ;;* ;;This belongs to automatic install, below is empty line code
7013 RE ,regexp matching the examples
7014 CH character signifying empty lines
7022 (unless (and beg end)
7023 (pop-to-buffer (current-buffer))
7024 (error "ti::package-rip: Region not defined %s" (current-buffer)))
7026 (narrow-to-region beg end)
7028 (when (re-search-forward re nil t)
7030 (save-excursion (delete-non-matching-lines re))
7031 ;; Now we have only RE lines
7033 (when (looking-at re)
7034 (delete-region (match-beginning 0) (match-end 0))
7035 (if (looking-at ch) ;remove that char
7041 ;;; ----------------------------------------------------------------------
7043 (defun ti::package-rip-magic (beg end &optional verb)
7044 "As `ti::package-rip' BEG END, except the area is pasted to temporary buffer.
7045 Tthe lines are prepared AND the result is inserted to register. VERB.
7047 Make sure your are viewing the piece of code in the same mode that it is
7048 supposed to be used. Otherwise the magic syntax isn't regognized.
7053 (let* ((ob (current-buffer))
7054 (str (ti::package-make-var))
7056 (reg ?p) ; "p" as "package"
7062 Couldn't set rip syntax, maybe `comment-start' is not defined.")
7064 (insert-buffer-substring ob beg end) ;get the area
7065 (setq re (concat "^" (regexp-quote str)))
7066 (setq ret (ti::package-rip re empty (point-min) (point-max)))
7067 (pop-to-buffer (current-buffer))
7070 (set-register reg (buffer-string))
7072 (message "Example ripped to register `%c' " reg)))
7075 (message "could find Rip regexp `%s' from region." re))))))
7078 ;;; ----------------------------------------------------------------------
7080 (defun ti::package-make-mode-magic (beg end)
7081 "As `ti::package-make-mode', except BEG END is pasted to temporary buffer.
7082 The lines are prepared AND the result is inserted to register.
7085 t or nil according to success."
7087 (let* ((source (current-buffer)) ;source buf
7088 (m major-mode) ;we must use same mode
7089 (verb (interactive-p))
7092 (insert-buffer-substring source beg end)
7093 ;; turning mode on may have effects, since it runs hooks...
7095 (funcall m) ;turn on same mode
7096 (when (ti::package-make-mode (point-min) (point-max))
7097 (set-register reg (buffer-string))
7099 (message "example in register `%c'" reg))))))
7101 ;;; ----------------------------------------------------------------------
7104 (defun ti::package-make-mode (beg end)
7105 "Make embedded package around BEG END according to mode.
7106 ** DOES NOT WORK FOR MODES WITH `comment-end' ***
7109 nil or t if successfull."
7111 (let* ((str (ti::package-make-var))
7114 (if (not (ti::nil-p comment-end))
7115 (message "tinylib: Comment end found, cannot proceed.")
7116 (ti::package-make beg end str empty)
7120 ;;; ----------------------------------------------------------------------
7122 (defun ti::package-make-var ()
7123 "Return Packaging variable 'str' according to mode.
7124 If mode has no comment syntax default ';;* ' is used."
7125 (let* ((cs comment-start)
7126 (cs (cond ;set up something special
7128 '(lisp-mode emacs-lisp-mode lisp-interaction-mode))
7129 (setq cs ";;")) ;default ';' isn't enough
7130 (t cs))) ;do not change it
7133 ;; make sure there is space
7137 ;;; ----------------------------------------------------------------------
7139 (defun ti::package-make (beg end str ch)
7140 "Format area for automatic install.
7145 STR string to be added at front
7146 CH additional character for empty lines."
7147 (let* ((empty (concat str
7150 (char-to-string ch))
7154 (narrow-to-region beg end)
7155 (goto-char (min beg end))
7157 (if (looking-at "^[ \t]*$")
7160 (forward-line 1)))))
7162 ;;; ----------------------------------------------------------------------
7164 (defun ti::package-autoload-create-on-file
7165 (file &optional buffer no-show no-desc)
7166 "Very simple autoload function generator out of FILE.
7167 Optionally put results to BUFFER. NO-SHOW does not show buffer.
7171 Doesn't recognize ###autoload tags; reads only functions.
7175 FILE Lisp .el to read
7176 BUFFER Where to insert autoloads.
7177 NO-SHOW Do not show autoload buffer
7178 NO-DESC Do not include function description comments."
7179 (interactive "fConstruct lisp autoloads from file: ")
7180 (let* ((fn (file-name-nondirectory file))
7183 "defun\\|defmacro\\|defsubst"
7185 "\\|defun-maybe\\|defsubst-maybe\\|defmacro-maybe"
7188 "[ \t]+\\([^ \t\n(]+\\)[ \t]*"))
7199 (setq buffer (get-buffer-create (or buffer "*Autoloads*"))))
7200 ;; We want to say (autoload 'func "pacakge" t t)
7201 ;; and not (autoload 'func "pacakge.el" t t)
7202 ;; so that .elc files can be used.
7203 (if (string-match "\\(.*\\).el" fn)
7204 (setq fn (match-string 1 fn)))
7205 (unless (setq read-buffer (find-buffer-visiting file))
7206 (setq read-buffer (setq tmp (ti::find-file-literally file))))
7207 (with-current-buffer read-buffer
7208 ;; Can't use forward-sexp etc otherwise
7209 (unless (string-match "lisp" (symbol-name major-mode))
7210 (let (emacs-lisp-mode-hook) ;; Run no hooks
7211 (if emacs-lisp-mode-hook ;; Quiet ByteCompiler "unused var"
7212 (setq emacs-lisp-mode-hook nil))
7214 (ti::append-to-buffer
7215 buffer (concat "\n;; "
7216 (file-name-nondirectory file)
7222 (while (re-search-forward regexp nil t)
7223 (setq iact nil ;interactive flag
7225 type (match-string 1)
7226 func (match-string 2))
7229 (goto-char (goto-char (match-end 0)))
7230 (when (search-forward "(" nil t)
7231 (setq point (point))
7237 (subst-char-in-string
7238 ;; Convert multiline args to one line.
7240 (buffer-substring point (point)) )))))
7241 (if (re-search-forward
7242 "[ \t\n]+([ \t]*interactive"
7243 (save-excursion (end-of-defun) (point))
7248 (setq args (format ";; %-36s <args not known>\n" func))
7250 (setq args (format ";; %s\n" func)))
7251 ((> (length args) 32)
7252 (setq args (format ";; %-15s %s\n" func args)))
7254 (setq args (format ";; %-36s %s\n" func args)))))
7256 ;; (autoload FUNCTION FILE &optional DOCSTRING INTERACTIVE TYPE)
7257 (setq str (format "(autoload '%-36s %s \"\" %s%s)%s\n"
7259 (format "\"%s\"" fn)
7261 (if (string-match "defmacro" type )
7263 (if (string= type "defsubst")
7264 (format ";;%s" type) "")))
7265 (ti::append-to-buffer buffer str)
7268 (with-current-buffer buffer
7269 (insert "\n") ;list arguments for functions.
7270 (dolist (elt list) (insert elt)))))
7271 (if tmp ;We loaded this to Emacs, remove it
7274 (pop-to-buffer buffer)
7278 ;;; ----------------------------------------------------------------------
7280 (defun ti::package-autoload-create-on-directory
7281 (dir &optional buffer no-show no-desc)
7282 "Create autoloads from function definitions in lisp files in DIR.
7283 Optionally put results to BUFFER. NO-SHOW does not show buffer.
7287 Doesn't recognize ###autoload tags; reads only functions.
7291 See argument description in function `ti::package-autoload-create-on-file'."
7292 (let* ((files (directory-files
7296 (dolist (file files)
7297 (ti::package-autoload-create-on-file file buffer no-show no-desc))))
7299 ;;; ----------------------------------------------------------------------
7301 (defun ti::package-autoload-loaddefs-create-maybe (file)
7302 "Make sure `generated-autoload-file' exists for FILE."
7303 (unless (file-exists-p file)
7304 (let* ((name1 (file-name-nondirectory file)))
7307 (format ";;; %s -- " name1)
7308 "loaddef definitions of program files\n"
7309 ";; Generate date: " (format-time-string "%Y-%m-%d" (current-time))
7311 ;; This file is automatically generated. Do not Change."
7313 (format "\n(provide '%s)\n\n"
7314 (file-name-sans-extension (file-name-nondirectory name1))))
7315 (ti::with-coding-system-raw-text
7316 (write-region (point-min) (point-max) file))))))
7318 ;;; ----------------------------------------------------------------------
7320 (defun ti::package-autoload-loaddefs-dir-files (dir &optional regexp)
7321 "Return from DIR .el files that do not matching REGEXP.
7322 TO-FILE is excluded from autoload search."
7324 (dolist (file (directory-files dir 'abs))
7325 (when (and (not (file-directory-p file))
7326 (string-match "\.el$" file)
7328 (not (string-match regexp file))))
7332 ;;; ----------------------------------------------------------------------
7334 (defun ti::package-autoload-loaddefs-build-dir-1 (dir &optional regexp to-file)
7335 "Build autoloads in DIR not matching REGEXP TO-FILE."
7336 (let ((files (ti::package-autoload-loaddefs-dir-files dir regexp)))
7339 ;; the original Emacs autload.el var does not contain "^"
7340 ;; and this picks up wrong autoload definitions e.g. in
7341 ;; auctex/tex-info.el which contains code
7342 ;; ;;; Do not ;;;###autoload because conflicts standard texinfo.el.
7343 ;; (defun texinfo-mode ()
7345 ;; (generate-autoload-cookie "^;;;###autoload")
7347 ;; ...but, we cannot do that because
7348 ;; generate-autoload-cookie is not a regexp, because in
7349 ;; autoload.el there is statement in
7350 ;; generate-file-autoloads()
7352 ;; (regexp-quote generate-autoload-cookie)
7357 ;; buffer-auto-save-file-name
7360 (auto-save-interval 0)
7361 (original-backup-inhibited backup-inhibited)
7362 (backup-inhibited t))
7363 ;; Reset also global
7364 (setq-default backup-inhibited t)
7365 ;; When each file is loaded to emacs, do not turn on lisp-mode
7366 ;; or anything else => cleared file hooks. These are byte compiler
7368 (if (null find-file-hooks)
7369 (setq find-file-hooks nil))
7370 (if (null write-file-hooks)
7371 (setq write-file-hooks nil))
7372 (if (null font-lock-mode)
7373 (setq font-lock-mode nil))
7374 (if (null auto-save-hook)
7375 (setq auto-save-hook nil))
7376 (if (null auto-save-default)
7377 (setq auto-save-default nil))
7378 (if auto-save-interval
7379 (setq auto-save-interval 0))
7380 (if backup-inhibited
7381 (setq backup-inhibited t))
7382 (ti::package-autoload-loaddefs-create-maybe to-file)
7383 (dolist (file files)
7384 ;; (message "TinyLib: Updating loaddefs %s %s"
7385 ;; generated-autoload-file file)
7386 (message "TinyLib: Updated loaddefs %s => %s" dir to-file)
7387 (update-file-autoloads file))
7388 (setq-default backup-inhibited original-backup-inhibited)))))
7390 ;;; ----------------------------------------------------------------------
7392 (defun ti::package-autoload-loaddefs-build-dir
7393 (dir to-file &optional regexp force)
7394 "Build autoloads in DIR TO-FILE like like `update-file-autoloads' does.
7399 TO-FILE The autoload file
7400 REGEXP Ignore files matching regexp.
7401 FORCE If non-nil, delete previous TO-FILE."
7402 (let* ((generated-autoload-file to-file) ;; See autoload.el, must be bound
7403 (name (file-name-nondirectory to-file))
7404 (buffer (find-buffer-visiting to-file))
7406 (unless generated-autoload-file ;; just byte compiler silencer.
7407 (setq generated-autoload-file nil))
7408 ;; Exclude to-file from search.
7410 (setq regexp (concat regexp "\\|" (regexp-quote name)))
7411 (setq regexp (regexp-quote name)))
7413 (ti::kill-buffer-safe buffer)
7416 (file-exists-p to-file))
7417 (ti::file-delete-safe to-file))
7418 ;;; (dolist (file (ti::package-autoload-loaddefs-dir-files dir regexp))
7419 ;;; (message "TinyLib: loaddefs %s %s" generated-autoload-file file)
7420 ;;; (update-file-autoloads file))
7421 (ti::package-autoload-loaddefs-build-dir-1 dir regexp to-file)
7422 (when (setq buffer (find-buffer-visiting to-file))
7423 (with-current-buffer buffer
7424 (let (buffer-auto-save-file-name
7427 (when load ;; Reload, because buffer was in Emacs
7428 (find-file-noselect to-file))))
7430 ;;; ----------------------------------------------------------------------
7432 (defun ti::package-autoload-directories (list)
7433 "Return only directories from LIST, excluding version control directories."
7436 (when (and (file-directory-p elt)
7439 "[/\\]\\..?$\\|CVS\\|RCS"
7444 ;;; ----------------------------------------------------------------------
7446 (defun ti::package-autoload-loaddefs-build-recursive
7447 (dir regexp &optional force function)
7448 "Build like `update-file-autoloads' recursively below DIR.
7451 DIR Root directory to start searching
7452 REGEXP Regexp to exclude files.
7453 FORCE Recreate TO-FILE from scratch by deleting previous.
7454 You should do this if you have renamed any files in the directories.
7455 FUNCTION Function to return autoload filename for each directory.
7456 Called with arg `dir'. The default file is loaddefs.el."
7457 (interactive "DEmacs autoload build root:\nfTo file: ")
7460 (let* ((dirs (ti::package-autoload-directories
7462 (expand-file-name dir)
7464 (to-file (or (and function
7465 (funcall function dir))
7469 (ti::package-autoload-loaddefs-build-dir dir to-file regexp force)
7471 (ti::package-autoload-loaddefs-build-recursive
7472 dir regexp force function)))
7474 (ti::package-autoload-loaddefs-build-dir dir to-file regexp force)))))
7476 ;;; ----------------------------------------------------------------------
7478 (defun ti::package-install-pgp-tar (dir &optional log-buffer source test)
7479 "Install PGP signed tar block using DIR from the end of current buffer.
7480 The 'BEGIN PGP MESSAGE' is searched from the end of buffer backward.
7482 The TAR block in the buffer looks like this and it is base64 pgp
7483 signed (clearsig is off) with Author's public key.
7485 ;; -----BEGIN PGP MESSAGE-----
7488 ;; owHsWc1vG0l2n0GwwYjA3pJLgEXKlNaSDJLilySblrWWLXrMrCQrpOydzcxA02wW
7491 ;; -----END PGP MESSAGE-----
7495 o Asks to what directory the tar files are installed.
7496 o shows the log buffer and echoes commads used.
7497 o Calls pgp to unpack the signed block
7498 o Calls tar to unpack the files
7499 o temporary files are stored to TMP, TMPDIR or /tmp
7503 o if 'pgp' executable is not found, function aborts.
7504 o if 'tar' executable is not found, function aborts.
7505 o if previously installed files exists, function aborts.
7509 DIR where to unpack the files
7510 LOG-BUFFER where to print log messages.
7511 SOURCE instead of using current buffer, read this file"
7513 (interactive "DSave programs to directory: ")
7515 (pgp (or (and (executable-find "pgp")
7516 ;; Do not use returned absolute path
7517 ;; due to platform independency
7519 (message "TinyLib: Can't find `pgp'.")))
7520 (gpg (or (and (executable-find "pgp")
7522 (message "TinyLib: Can't find `gpg'.")))
7523 (pgp-bin (or pgp gpg))
7524 (tar (or (executable-find "tar")
7525 (error "TinyLib: Can't find 'tar'.")))
7526 (tmp (or (and (getenv "TMP")
7527 (ti::file-make-path (getenv "TMP")))
7528 (and (getenv "TMPDIR")
7529 (ti::file-make-path (getenv "TMPDIR")))
7531 ;; This may be system dependent someday..
7532 (tar-opt-show "tvf")
7534 (obuffer (current-buffer))
7535 (in-file (expand-file-name (concat tmp "t.in")))
7536 (out-file (expand-file-name (concat tmp "t.out")))
7545 (error "TinyLib: PGP or GPG is required to unpack."))
7546 ;; We need to expand this for shell calls
7547 (setq dir (expand-file-name (ti::file-make-path dir)))
7550 (not (file-exists-p source)))
7551 (error "TinyLib: Can't find '%s'" source))
7552 ((not (file-directory-p tmp))
7553 (error "TinyLib: Can't use directory '%s'. Set env variable TMP." tmp))
7554 ((not (file-exists-p dir))
7555 (error "TinyLib: No such directory %s." dir)))
7556 (setq buffer (ti::temp-buffer
7557 (or log-buffer "*tinylib::install*")
7559 (with-current-buffer buffer
7560 ;; .............................................. extract base64 ...
7561 (buffer-disable-undo)
7563 (insert-file-contents source)
7564 (insert-buffer obuffer))
7566 (unless (re-search-backward
7567 (concat "^;;+[ \t]*\\(" (ti::mail-pgp-msg-end-line) "\\)")
7569 (pop-to-buffer (current-buffer))
7570 (error "TinyLib: Can't find PGP end %s " source))
7571 (setq end (match-beginning 1))
7572 (unless (re-search-backward
7573 (concat "^;;+[ \t]*" (ti::mail-pgp-msg-begin-line))
7575 (pop-to-buffer (current-buffer))
7576 (error "TinyLib: Can't find PGP beginning %s " source))
7579 (delete-rectangle (point) end)
7580 ;; Leave only the signed region, remove rest
7581 (delete-region (point-min) (point))
7582 (buffer-enable-undo)
7583 ;; .................................................... call pgp ...
7584 (setq cmd (format "%% rm %s %s\n" in-file out-file))
7586 (ti::file-delete-safe (list in-file out-file)))
7587 (write-region (point-max) (point-min) in-file)
7588 (unless (file-exists-p in-file)
7589 (error "TinyLib: Writing PGP data failed to file %s" in-file))
7590 ;; Write-file may have some strange modes, be sure we can read them
7592 (set-file-modes in-file (logior (file-modes in-file) 384))
7594 ;; Start showing the log to user
7595 (pop-to-buffer buffer)
7597 (let* ((out-file (ti::file-name-forward-slashes out-file))
7598 (default-directory (file-name-directory out-file))
7599 (file (file-name-nondirectory out-file)))
7600 (insert (format "%% cd %s ; %s -o %s %s\n"
7604 (file-name-nondirectory in-file)))
7606 (call-process pgp-bin
7610 "-o" file (file-name-nondirectory in-file))
7612 (unless (re-search-forward "Plaintext filename:" nil t)
7613 (error "TinyLib: Can't proceed, PGP didn't set filename.")))
7614 ;; .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. show tar content ..
7616 (setq cmd (format "cd %s ; %s %s %s"
7622 (insert "% " cmd "\n") (setq beg (point))
7629 (if (null (setq file-list (ti::process-tar-read-listing-forward)))
7630 (error "TinyLib: Can't find tar listing."))))
7631 ;; .. .. .. .. .. .. .. .. .. .. .. .. .. previously installed? ..
7632 (setq list file-list)
7634 (setq in (concat dir (car elt)))
7635 (when (file-exists-p in)
7638 "TinyLib: Previously installed file `%s'. Overwrite ? "
7642 (error "Abort.")) ))
7643 (setq cmd (format "cd %s ; tar %s %s"
7644 (expand-file-name dir)
7647 (insert "% "cmd "\n")
7649 (let* ((default-directory (expand-file-name dir)))
7650 (call-process tar nil buffer nil
7652 (expand-file-name out-file))))
7653 ;; .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. . clean ..
7654 (when (y-or-n-p "TinyLib: Clean up tmp files? ")
7655 (push in-file file-list)
7656 (push out-file file-list)
7657 (dolist (elt file-list)
7658 (insert (format "%% rm %s\n" elt))
7660 (ti::file-delete-safe elt) )))
7661 (message "TinyLib: installation to %s complete" dir))))
7664 ;;{{{ misc: XEmacs compatibility
7666 ;;; ----------------------------------------------------------------------
7668 (defun ti::compat-installation-root ()
7669 "Return XEmacs installation root directory without trailing slash.
7670 If this is queried unde Emacs, `exec-path' must contain XEmacs binary,
7671 otherwise `load-path' is conculted."
7672 (let* ((xemacs (ti::xemacs-p))
7674 (ti::emacs-version-number-as-string))) ;eg "19.14"
7677 (dolist (path (if xemacs
7680 ;; When we find the version from the path, ve know the root
7683 ;; /opt/local/lib/xemacs-19.14/lisp/vms -->
7684 ;; /opt/local/lib/xemacs-19.14/lisp/
7685 (when (and (stringp path)
7686 (string-match "xemacs" path)
7688 ;; running under XEmacs, we know what to look for.
7689 (setq match (ti::string-match
7690 (concat "^.*" ver) 0 path))
7691 ;; Take a guess, anything that looks like XEmacs in path
7694 ;; XEmacs-21.2.36/ or XEmacs/21.2.36/
7695 "^\\(.*xemacs[-\\/][0-9]+\\.[0-9.]*[0-9]\\)[\\/]"
7697 (setq ret (concat match "/lisp"))
7701 ;;; ----------------------------------------------------------------------
7703 (defun ti::compat-overlay-some ()
7704 "Return some existing overlay that is used in Emacs.
7705 Usually the primary mouse selection. You can use this function to get an
7706 overlay that you can move in text if you don't want to create
7712 ((and (ti::xemacs-p)
7713 (boundp 'primary-selection-extent))
7714 'primary-selection-extent)
7716 (boundp 'mouse-drag-overlay))
7717 'mouse-drag-overlay)))
7719 ;;; ----------------------------------------------------------------------
7721 (defun ti::compat-overlay-properties (overlay)
7722 "Return properties of OVERLAY."
7724 ((ti::overlay-supported-p)
7725 (ti::funcall 'overlay-properties overlay))
7727 (ti::funcall 'extent-properties overlay))))
7729 ;;; ----------------------------------------------------------------------
7731 (defun ti::compat-overlays-at (point)
7732 "Return overlays at POINT."
7734 ((ti::overlay-supported-p)
7735 (ti::funcall 'overlays-at point))
7740 (function (lambda (ov maparg) (push ov list)))
7741 (current-buffer) point point)
7744 ;;; ----------------------------------------------------------------------
7746 (defun ti::compat-overlay-put (ov-sym prop val)
7747 "Set properties to overlay OV-SYM. Put PROP VAL pair to OV-SYM."
7749 ((ti::overlay-supported-p)
7750 (ti::funcall 'overlay-put (symbol-value ov-sym) prop val))
7752 (ti::funcall 'set-extent-property (symbol-value ov-sym) prop val))))
7754 ;;; ----------------------------------------------------------------------
7756 (defun ti::compat-overlay-move (ov-sym beg end &optional make-local face)
7757 "Move overlay OV-SYM to BEG END. Overlay is created if it does not exist.
7758 MAKE-LOCAL localizes the overlay. If the overlay is created,
7759 then FACE is assigned to it (default 'highlight)"
7761 ((ti::overlay-supported-p)
7762 ;; ................................................ create overlay ...
7763 ;; later XEmacs may have overlay emulation
7764 (or (symbol-value ov-sym) ;Exist?
7766 (if make-local (make-local-variable ov-sym))
7768 (ti::funcall 'make-overlay (point) (point)))
7769 (ti::funcall 'overlay-put
7770 (symbol-value ov-sym)
7771 'face (or face 'highlight))))
7772 ;; .......................................................... move ...
7773 (ti::funcall 'move-overlay (symbol-value ov-sym)
7774 beg end (current-buffer)))
7776 (or (symbol-value ov-sym) ;Exist?
7778 (if make-local (make-local-variable ov-sym))
7780 (ti::funcall 'make-extent (point) (point)))
7781 (ti::funcall 'set-extent-property
7782 (symbol-value ov-sym)
7783 'face (or face 'highlight))))
7784 (ti::funcall 'set-extent-endpoints
7785 (symbol-value ov-sym)
7786 beg end (current-buffer)))))
7788 ;;; ----------------------------------------------------------------------
7790 (defun ti::compat-activate-region (&optional off)
7791 "Activate region or turn the region OFF."
7793 (ti::funcall 'transient-mark-mode (if off 0 1)) ;From Simple.el
7795 (ti::funcall 'zmacs-deactivate-region)
7796 (set 'zmacs-regions (if off nil t)) ;Avoid bute compile mesage in Emacs
7797 (ti::funcall 'activate-region))))
7799 ;;; ----------------------------------------------------------------------
7801 (defun ti::compat-read-password (&optional prompt)
7802 "Read password with PROMPT which defaults to 'Password: '."
7803 (let* ((var-bind (boundp 'record-keystrokes))
7804 ;; If a GC occurred during that timing window, and a core dump was
7805 ;; forced later, the core might contain the string.
7806 ;; --> use most-positive-fixnum
7807 (gc-cons-threshold (* 1024 1024))
7808 record-keystrokes) ;XEmacs 20.4
7809 (setq prompt (or prompt "Password: "))
7813 ;; if one follows the
7814 ;; - as soon as you are done with the returned string,
7815 ;; destroy it with (fillarray string 0).
7817 (require 'passwd) ;utils/passwd.el
7818 (ti::funcall 'read-passwd prompt))
7820 ;; Could also use (comint-read-noecho prompt)
7821 ;; Comint won't echo anything.
7822 (ti::query-read-input-as-password prompt)))
7823 ;; ByteComp silencer; non used variable
7824 (if record-keystrokes
7825 (setq record-keystrokes nil))
7826 ;; In old Emacs versions 19.35< and XEmacs 19.16< 20.3<
7827 ;; you can actually read the password from lossage buffer with C-h l
7829 ;; --> We can clear it by filling it with 100 new characters.
7830 ;; But this really works in XEmacs only, because Emacs
7831 ;; Doesn't log events from macros.
7834 ((fboundp 'clear-lossage)
7835 (ti::funcall 'clear-lossage))
7836 ((fboundp 'clear-recent-keys)
7837 (ti::funcall 'clear-recent-keys))
7838 ((and (ti::xemacs-p)
7840 (save-window-excursion
7842 ;; force writing "1" x 100 in this buffer
7844 (switch-to-buffer (current-buffer))
7845 (ti::dotimes counter 1 100 (execute-kbd-macro "1")))))))))
7847 ;;; ----------------------------------------------------------------------
7849 (defun ti::compat-key-local-map (key)
7850 "Return local map function for KEY"
7851 (let* ((prop (text-properties-at (point)))
7853 (nth 1 (memq 'keymap prop))))
7855 (lookup-key map key))))
7858 ;;; ----------------------------------------------------------------------
7860 (defun ti::compat-key-call-original (minor-mode-symbol key-binding)
7861 "Turn of MINOR-MODE-SYMBOL and execute original KEY-BINDING.
7862 This won't work on mouse commands that examine the mouse `event'"
7863 (let* ((map (or (current-local-map) global-map))
7864 (function (lookup-key map key-binding))
7865 (this-command (if function function this-command)))
7866 (when (and (not (ti::bool-p function))
7871 (put minor-mode-symbol 'ti::orig-value-key
7872 (symbol-value minor-mode-symbol))
7873 (set minor-mode-symbol nil)
7874 ;; This is very simplistic call. E.g. mouse event should
7875 ;; be called with (funcall function event)
7876 (call-interactively function)))
7877 ;; Make sure minor mode setting is restored
7878 (set minor-mode-symbol
7879 (get minor-mode-symbol 'ti::orig-value-key)))))
7881 ;;; ----------------------------------------------------------------------
7883 (defun ti::compat-mouse-position-coordinates ()
7884 "Return '(LINE COLUMN) where mouse pointer is currently.
7885 If mouse is not supported, return nil."
7886 (when (fboundp 'mouse-position)
7887 (let ( ;; (frame (car (mouse-position)))
7888 (x (cadr (mouse-position)))
7889 (y (cddr (mouse-position))))
7890 ;; window-list returns all windows starting from TOP. Count
7891 ;; Lines in every window and compare that to mouse-position
7892 (let ((win (get-buffer-window (current-buffer)))
7894 (save-window-excursion
7895 (dolist (elt (window-list))
7899 ;; Modeline is not counted as +1
7900 (setq count (+ count (window-height)))))
7901 ;; (ti::d! count x y)
7902 (list (1+ (- y count))
7903 ;; In Emacs 21.x there is a "fringe" that mouse-position
7906 ;; Consider "fringe" as column 0
7908 ;; Removed "fringe" count
7911 ;;; ----------------------------------------------------------------------
7913 (defun ti::compat-mouse-key (event)
7914 "Return mouse key for EVENT."
7917 (make-vector 1 (car event)))
7920 (append (event-modifiers event)
7924 (ti::funcall 'event-button event)))))))))
7926 ;;; ----------------------------------------------------------------------
7928 (defun ti::compat-mouse-call-original-function (minor-mode-symbol &optional event)
7929 "Return original function behind MINOR-MODE-SYMBOL with mouse EVENT.
7930 See. `ti::-xe-mouse-call-original'."
7934 (setq event last-input-event))
7935 (when (or (null minor-mode-symbol)
7936 (not (symbolp minor-mode-symbol))
7937 (not (boundp minor-mode-symbol)))
7938 (error "Invalid minor-mode-symbol `%s'." minor-mode-symbol))
7939 ;; Turn off minor mode, so that we can see the real
7940 ;; function behind it.
7941 (put minor-mode-symbol 'ti::orig-value (symbol-value minor-mode-symbol))
7942 (set minor-mode-symbol nil)
7943 ;; Unfortunately if flyspell is active (mouse-2 binding), ir does not look
7944 ;; key definition of mouse-2, but a `this-command-keys',
7945 ;; which is not correct.
7946 ;; => Turn off flyspell if there is no flyspell overlay underneath
7947 (when (and (boundp 'flyspell-mode)
7949 (fboundp 'flyspell-overlay-p)
7950 (not (ti::funcall 'flyspell-overlay-p (overlays-at (point)))))
7951 (put minor-mode-symbol 'ti::orig-value-flyspell flyspell-mode)
7953 (setq flyspell-mode nil))
7954 (setq ret (key-binding (ti::compat-mouse-key event))) ;Read it
7955 ;; Restore active modes
7957 (put minor-mode-symbol 'ti::orig-value-flyspell flyspell-mode))
7958 (set minor-mode-symbol (get minor-mode-symbol 'ti::orig-value))
7961 ;;; ----------------------------------------------------------------------
7963 (defvar ti::-xe-mouse-call-original nil "See ti::keymap-mouse-call-original.")
7965 (defun ti::compat-mouse-call-original (minor-mode-symbol &optional event)
7966 "Execute original mouse function by turning of MINOR-MODE-SYMBOL.
7967 EVENT is mouse event. You use this function to to handle 'hot spots' in the
7968 buffer and in other places you call the original function.
7970 Do nothing if original function does not exist.
7971 Does nothing when called by a function which has earlier been called
7974 Example for some minor mode implementation:
7976 ext-pro (defun folding-mode-context-sensitive (event)
7978 ;; If test.. if test..no, then call original function
7979 (ti::compat-mouse-call-original 'folding-mode event))
7983 Works in XEmacs and Emacs
7987 `ti::-xe-mouse-call-original'"
7988 ;; Without the following test we could easily end up in a endless
7989 ;; loop in case we would call a function which would call us.
7990 (if ti::-xe-mouse-call-original ;; We're looping already
7992 (setq ti::-xe-mouse-call-original t)
7994 (let* ((orig-buf (current-buffer))
7995 (mouse-func (ti::compat-mouse-call-original-function
7996 minor-mode-symbol event))
7997 (local-func (ti::compat-key-local-map
7998 (ti::compat-mouse-key event)))
7999 (orig-func (or local-func
8001 (event-p (when orig-func
8004 (or (ti::function-args-p orig-func)
8008 ;; call it with the event as argument.
8009 ;; We have to restore the current buffer too, because
8010 ;; the minor mode is there.
8011 (put minor-mode-symbol 'ti::orig-value
8012 (symbol-value minor-mode-symbol))
8015 (funcall orig-func event)
8016 ;; Try direct call first, or pass the EVENT
8017 (or (eq 'done (progn (call-interactively orig-func) 'done))
8018 (eq 'done (progn (funcall orig-func event) 'done))))
8019 (set-buffer orig-buf)
8020 (set minor-mode-symbol (get minor-mode-symbol
8021 'ti::orig-value)))))
8022 ;; .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. unwind ..
8023 ;; This is always executed, even if the above generates an error.
8024 (setq ti::-xe-mouse-call-original nil))))
8026 ;;; ----------------------------------------------------------------------
8028 (defun ti::compat-popup (string-list &optional event mode title)
8029 "Show STRING-LIST pop up. If EVENT is nil, use default tinylib coordinates.
8030 Works in XEmacs and Emacs.
8034 STRING-LIST '(str str ..)
8035 EVENT mouse-event or nil
8036 MODE if non-nil, return selection NBR [0..n]. Normally
8037 returns the selection itself.
8038 TITLE title of popup
8042 selection member or nbr
8043 nil nothing selected"
8045 (let* ((title (or title ""))
8047 ;; Allow calling from key press also.
8049 (ti::compat-make-x-popup-event
8050 ti::var-x-coord ti::var-y-coord)))
8055 (when (ti::listp string-list)
8056 (setq alist (ti::list-to-assoc-menu string-list))
8059 (setq item-list alist)
8062 (list (cons title item-list))))
8063 (if (fboundp 'x-popup-menu)
8064 (setq ret (ti::funcall 'x-popup-menu event menu)))
8067 (setq ret (nth ret string-list)))))
8069 ;; Scenario: User selects item from menu-bar-menu which calls
8070 ;; function that should be called from mouse press --> selecting
8071 ;; from pull-down-menu, is not a mouse event!
8073 ;; First one is real mouse call for function; the other one
8074 ;; is called from popup selection
8076 ;; #<buttondown-event button1>
8077 ;; #<misc-user-event (call-interactively tig-index-x-popup)>
8079 ;; get-popup-menu-response call breaks if EVENT is something
8080 ;; else than mouse-event. Check it immediately and set EVENT
8081 ;; to nil, because the parameter is optional.
8082 (if (and event (null (ti::funcall 'mouse-event-p event)))
8084 ;; Menu format is like this in XEmacs
8086 ;; '("title" ["A" ("A") t] ["B" ("B") t] ["C" ("C") t]
8087 (setq item-list string-list)
8091 (lambda (x &optional vec)
8092 (setq vec (make-vector 3 nil))
8094 (aset vec 1 (list x))
8098 (setq menu (push title menu))
8099 ;; #todo, I don't know why there is nothing in the RET
8100 ;; after the selection has been done...
8103 (setq ret (ti::funcall 'get-popup-menu-response menu event ))
8104 (if (ti::funcall 'misc-user-event-p ret)
8105 (setq ret (car-safe (ti::funcall 'event-object ret))))
8106 (when (and ret mode) ;find position in list
8108 (when (and (vectorp arg)
8109 (string= ret (elt arg 0)))
8110 (setq ret (1- count))
8115 ;;; ----------------------------------------------------------------------
8117 (defun ti::compat-display-depth ()
8118 "Return how many colors display can show."
8121 (ti::funcall 'x-display-planes (symbol-value 'x-display-name)))
8123 (ti::funcall 'device-bitplanes (ti::funcall 'default-x-device)))))
8125 ;;; ----------------------------------------------------------------------
8127 (defun ti::compat-read-event ()
8131 (if (fboundp 'event-to-character)
8132 (ti::funcall 'read-event)
8133 (error "Cannot read events.")))
8135 (ti::funcall 'next-command-event))))
8137 ;;; ----------------------------------------------------------------------
8139 (defun ti::compat-executing-macro ()
8140 "Check if executing macro."
8142 ((boundp 'executing-macro)
8143 (symbol-value 'executing-macro)) ;Emacs and old XEmacs
8144 ((boundp 'executing-kbd-macro) ;New XEmacs
8145 (symbol-value 'executing-kbd-macro))))
8147 ;; briefly: events in 19.28, see subr.el
8148 ;; -------------------------------------------
8149 ;; event :(mouse-3 (#<window 34 on *scratch*> 128 (20 . 104) -23723628))
8151 ;; (setq event-start event)
8152 ;; event-start :(#<window 34 on *scratch*> 128 (20 . 104) -23723628))
8154 ;; mouse point coordinates
8156 ;; (setq posn-col-row event-start) --> turn (20 . 104) into (col row)
8158 (defun ti::compat-make-x-popup-event (x y)
8159 "Make fake EVENT using X and Y coordinates.
8160 Very handy if you call from kbd a function that requires mouse event."
8163 (list (list x y) (selected-window)))
8165 ;;; (message "ti::compat-make-x-popup-event, XEmacs implementation not known.")
8168 ;;; ----------------------------------------------------------------------
8170 (defun ti::compat-make-fake-event (x y &optional mouse-sym)
8171 "Make fake event using X and Y coordinates and MOUSE-SYM[mouse - 1].
8173 Remeber: this is not full blown fake, just sufficent one, if
8174 receiver uses any of 'posn-' function, this doesn't fool it."
8176 ;; (mouse-1 (#<window 42 on tinylib.el> 271088 (92 . 138) -492011))
8180 (or mouse-sym 'mouse-1 )
8183 1 ;<just some calue>
8187 ;; (message "ti::compat-make-fake-event, XEmacs implementation not known.")
8189 ;; You can't create fake events in XEmacs. The object data is
8190 ;; hidden behind an abstraction layer and there are no functions to
8191 ;; build or modify event objects. You can only allocate and copy
8196 ;;; ----------------------------------------------------------------------
8198 (defun ti::compat-modeline-update ()
8199 "XEmacs and Emacs Compatibility. Update modeline."
8201 ((and (ti::xemacs-p)
8202 (fboundp 'redraw-modeline))
8204 ;; force-mode-line-update is an obsolete function; use redraw-modeline
8205 (ti::funcall 'redraw-modeline))
8206 ((fboundp 'force-mode-line-update)
8207 (ti::funcall 'force-mode-line-update))
8209 (set-buffer-modified-p (buffer-modified-p)))))
8211 ;;; ----------------------------------------------------------------------
8212 ;;; - Changing the frame label is same as changing the icon label
8214 (defun ti::compat-set-frame-parameter (prop-or-list value &optional frame)
8215 "Use PROP-OR-LIST and VALUE to set FRAME's parameters.
8216 When called interactively, set name of the frame.
8219 PROP-OR-LIST alist of parameters or single property name
8221 VALUE only used if single property given.
8222 FRAME defaults to current frame."
8226 (read-from-minibuffer "frame label name: ")))
8227 (let* ((frame (or frame (selected-frame))))
8229 ((and (ti::xemacs-p)
8230 (fboundp 'set-frame-properties))
8231 ;; #todo: Why don't these work in XEmacs 19.14 ?
8232 (if (ti::listp prop-or-list)
8233 (ti::funcall 'set-frame-properties frame prop-or-list)
8234 (ti::funcall 'set-frame-property frame prop-or-list value)))
8236 (if (not (ti::listp prop-or-list))
8237 (setq prop-or-list (list (cons prop-or-list value))))
8238 (ti::funcall 'modify-frame-parameters frame prop-or-list)))))
8240 ;;; ----------------------------------------------------------------------
8242 (defun ti::compat-set-frame-name (string &optional frame get)
8243 "Change the frame display STRING in FRAME.
8244 The implementation works differently in various emacs versions.
8246 If GET is non-nil return frame name."
8247 (let* ((symbol 'name))
8249 ;; somewhere along the line the symbol was renamed to 'title
8250 ;; #todo: 19.31 - 33, frame, Would someone confirm this?
8251 (when (and (> emacs-minor-version 31)
8252 (< emacs-minor-version 34))
8253 (setq symbol 'title)))
8255 (frame-parameter frame symbol)
8256 (ti::compat-set-frame-parameter symbol string frame))))
8258 ;;; ----------------------------------------------------------------------
8260 (defun ti::compat-frame-window-config ()
8261 "Return list '((FRAME WINDOW-CONFIGURATION) (F W) ..)."
8264 (cdr (current-frame-configuration)))
8265 (push (list (nth 0 elt) (nth 2 elt)) ret))
8268 ;;; ----------------------------------------------------------------------
8269 ;;; XEmacs 19.14 "window-system is an obsolete variable; use (console-type)"
8271 (defun ti::compat-window-system ()
8272 "XEmacs and Emacs Compatibility, Mimic Emacs `window-system' variable.
8273 In XEmacs the `cosole-type' returns 'tty on terminal, but this function
8274 return nil to be in par with Emacs behavior. An 'tty is not a windowed
8277 ((fboundp 'console-type)
8278 (let ((val (ti::funcall 'console-type)))
8279 (unless (eq 'tty val)
8281 ((boundp 'window-system)
8282 (symbol-value 'window-system))))
8284 ;;; ....................................................... &xe-timers ...
8286 ;;; ----------------------------------------------------------------------
8288 (defun ti::compat-timer-list-control (&optional mode)
8289 "Timer handling: MODE can be 'save 'restore or 'kill.
8293 ;; Turn off all processes for a while...
8295 (ti::compat-timer-list-control 'save)
8296 (ti::compat-timer-list-control 'kill)
8300 ;; Now restore the prosesses
8302 (ti::compat-timer-list-control 'restore)"
8306 ((boundp 'timer-alist) 'timer-alist)
8307 ((boundp 'timer-list) 'timer-list)
8308 ((boundp 'itimer-list) 'itimer-list))))
8309 ;; We store/restore the list into the timer variable symbol
8315 (put sym 'ti::saved (symbol-value sym)))
8317 (set sym (get sym 'ti::saved))))))
8319 ;;; ----------------------------------------------------------------------
8322 (defun ti::compat-timer-control
8323 (&optional time repeat function delete verb)
8324 "With `run-at-time' TIME REPEAT FUNCTION keep or remove timer. VERB."
8327 (ti::compat-timer-cancel-function function)
8330 (if verb (message "TinyLib: timer process %s removed." function)))
8332 ;; this will also restart timer
8333 ;; In Emacs 19.28 - 19.30 , you could pass parameter
8334 ;; "now", but later emacs releases do not accept it.
8337 (run-at-time time repeat function))
8340 (message "TinyScroll: timer process started."))))
8343 ;;; ----------------------------------------------------------------------
8345 (defun ti::compat-timer-elt (function)
8346 "Search FUNCTION and return timer elt.
8347 You can use this function to check if some function is currently
8348 in timer list. (ie. active)
8350 The timer lists are searched in following order:
8358 '(timer-elt timer-variable)"
8363 (flet ((get-elt (elt place)
8367 (dolist (timer '( ;; (("Mon Dec 9 10:01:47 1996-0" 10 tipgp-process nil))
8368 (timer-idle-list . 5)
8370 (timer-list . 2) ;; 19.34+
8372 (when (boundp (car timer))
8373 (setq list (symbol-value (car timer))
8375 ;; NOTE: this is different in Xemacs. It is not a vector
8376 ;; timer-[idle-]list Emacs 19.34
8377 ;; NOTE: this is different in Xemacs. It is not a vector
8379 ;; ([nil 12971 57604 0 60 display-time-event-handler nil nil])
8380 ;; [nil 13971 14627 646194 60
8381 ;; (lambda (f) (run-at-time ...))
8382 ;; (irchat-Command-keepalive) nil]
8383 (if (and (ti::emacs-p)
8384 (vectorp (car list)))
8387 (setq item (get-elt elt pos))
8388 (when (or (and (symbolp item)
8390 ;; It may be lambda expression
8391 (and (functionp item)
8392 (string-match (regexp-quote (symbol-name function))
8394 (get-elt elt (1+ pos))))))
8395 (setq ret (list elt (car timer)))
8399 ;;; ----------------------------------------------------------------------
8401 (defun ti::compat-timer-process-status ()
8402 "XEmacs and Emacs Compatibility. Return timer process status: t if active."
8404 ((boundp 'timer-alist) ;Emacs
8405 (symbol-value 'timer-process))
8406 ((boundp 'timer-list) ;Emacs 19.34
8407 (ti::compat-timer-elt 'display-time-event-handler))
8408 ((boundp 'itimer-list) ;
8409 ;; it is built in in XEmacs
8412 ;;; ----------------------------------------------------------------------
8414 (defun ti::compat-timer-cancel (key &optional cancel-function)
8415 "Delete timer KEY entry, where KEY is full element in (i)`timer-alist'.
8416 Function `ti::compat-timer-cancel-function' may be more what you want
8417 if you know the function in timer list."
8421 (when (and (null var)
8422 (boundp 'timer-alist)) ;Emacs
8423 (setq var 'timer-alist)
8424 (ti::funcall 'cancel-timer key)
8425 (set var (delete key (symbol-value 'timer-alist))))
8427 (when (and (null var)
8428 (boundp 'timer-list)) ;Emacs 19.34
8429 (setq var 'timer-list)
8430 ;; Must use this command
8431 (ti::funcall 'cancel-timer key))
8432 (when (and (null var)
8433 (boundp 'timer-idle-list)) ;Emacs 19.34
8434 (setq var 'timer-idle-list)
8435 ;; Must use this command
8436 (ti::funcall 'cancel-timer key))
8437 (when (and (null var)
8438 (boundp 'itimer-list)) ;XEmacs
8439 (setq var 'itimer-list)
8440 (ti::funcall 'cancel-itimer key)
8441 (set var (delete key (symbol-value 'itimer-list))))
8444 ;;; ----------------------------------------------------------------------
8446 (defun ti::compat-timer-cancel-function (function)
8447 "Delete all timer entries for FUNCTION."
8450 (while (setq key (car-safe (ti::compat-timer-elt function)))
8452 (ti::compat-timer-cancel key))
8455 ;;; ----------------------------------------------------------------------
8457 (defun ti::compat-set-mode-line-format (fmt)
8458 "Set modeline format using FMT."
8463 ;; XEmacs 19.14 says:
8464 ;; ** mode-line-format is an obsolete var; use modeline-format instead.
8468 ;;{{{ misc: create standard functions, variables
8470 ;;; .......................................................... &fmacro ...
8472 ;;; ----------------------------------------------------------------------
8474 (defmacro ti::macrov-minor-mode
8477 mode-Name-prefix-key
8482 "Return standard minor mode variables.
8483 See below how to call this function from the top of your minor mode package.
8487 PFX string, the package prefix, usually one or two
8488 words. E.g. \"xxx\" or \"xxx-mode\"
8489 MODE-NAME string; which is displayed in modeline, should have
8490 leading space. E.g. \" Lisp\"
8491 MODE-NAME-PREFIX-KEY string, Key sequences to access the minor mode
8493 EASYMENU-NAME string, the Menu bar name string.
8494 CUSTOM-GROUP symbol, the defcustom.el group name.
8495 PREFIX-STYLE string, How the characters should be named.
8496 if nil then uses standard Emacs naming.
8501 STYLE is nil ;; Standard Emacs style
8503 (defvar xxx-mode nil)
8504 (make-variable-buffer-local 'xxx-mode)
8506 (defvar xxx-mode-name MODE-NAME)
8507 (defvar xxx-mode-prefix-key MODE-NAME-PREFIX-KEY)
8508 (defvar xxx-mode-map nil)
8509 (defvar xxx-mode-prefix-map nil)
8510 (defvar xxx-mode-define-keys-hook nil)
8511 (defvar xxx-mode-hook nil)
8512 (defvar xxx-mode-easymenu nil)
8513 (defvar xxx-mode-easymenu-name nil)
8520 (defvar xxx-mode nil)
8521 (make-variable-buffer-local 'xxx-mode)
8523 (defvar xxx-:mode-name MODE-NAME)
8524 (defvar xxx-:mode-prefix-key MODE-NAME-PREFIX-KEY)
8525 (defvar xxx-:mode-map nil)
8526 (defvar xxx-:mode-prefix-map nil)
8527 (defvar xxx-:mode-define-keys-hook nil)
8528 (defvar xxx-:mode-hook nil)
8529 (defvar xxx-:mode-easymenu nil)
8530 (defvar xxx-:mode-easymenu-name nil)
8532 How to call this function:
8534 (ti::macrov-minor-mode \"xxx\" \" Xmode\" \"C-cx\" \"Xmenubar\" nil)"
8535 (` (, (ti::macrov-minor-mode-1
8538 mode-Name-prefix-key
8543 ;;; ----------------------------------------------------------------------
8545 (defun ti::macrov-minor-mode-1
8548 mode-Name-prefix-key
8552 &optional prefix-style)
8553 "Use `ti::macrov-minor-mode' and see call arguments there.
8554 PFX MODE-NAME MODE-NAME-PREFIX-KEY
8555 EASYMENU-NAME CUSTOM-GROUP PREFIX-STYLE"
8560 (if (not (stringp prefix-style))
8561 (error "style must be string")
8562 (setq x prefix-style))
8564 ;;; (push 'progn ret)
8565 ;; Force seeing variables at compile time
8568 ;; Thee started to appear errors from easymenu define command and
8569 ;; after byte compiler was forced to see the defvar definitions
8570 ;; of the variables during compile time, the compile was clean again.
8572 ;; This was very odd.
8574 ;; (easy-menu-define
8575 ;; tdi-:mode-easymenu
8576 ;; tdi-:mode-map << if not defvar seen, gives error
8577 ;; "Elp summary sort menu."
8580 (push 'eval-and-compile ret)
8581 (setq sym (intern (format "%smode" pfx)))
8582 (push (list 'defvar (` (, sym)) nil
8583 "mode on off variable.")
8585 (push (list 'make-variable-buffer-local (` (quote (, sym)))) ret)
8587 (setq sym (intern (format "%smode-name" x)))
8588 (push (list 'defcustom (` (, sym))
8592 ':group (` (, custom-group)))
8594 (setq sym (intern (format "%smode-prefix-key" x)))
8595 (push (list 'defcustom (` (, sym))
8596 (` (, mode-Name-prefix-key))
8597 "*Prefix key to access mode."
8598 ':type ''(string :tag "Key sequence")
8599 ':group (` (, custom-group)))
8601 (setq sym (intern (format "%smode-map" x)))
8602 (push (list 'eval-and-compile
8608 (setq sym (intern (format "%smode-prefix-map" x)))
8609 (push (list 'eval-and-compile
8613 "Prefix minor mode map."))
8615 (setq sym (intern (format "%smode-easymenu" x)))
8616 (push (list 'defvar (` (, sym))
8618 "Easymenu variable.")
8620 (setq sym (intern (format "%smode-easymenu-name" x)))
8621 (push (list 'defcustom (` (, sym))
8622 (` (, easymenu-Name))
8623 "*Easymenu name that appears in menu-bar."
8625 ':group (` (, custom-group)))
8627 (setq sym (intern (format "%smode-define-keys-hook" x)))
8628 (push (list 'defcustom (` (, sym))
8630 "*Hook that defines all keys and menus."
8632 ':group (` (, custom-group)))
8634 (setq sym (intern (format "%smode-hook" x)))
8635 (push (list 'defcustom (` (, sym))
8637 "*Hook that runs when mode function is called."
8639 ':group (` (, custom-group)))
8643 ;;; ----------------------------------------------------------------------
8645 (defmacro ti::macrof-minor-mode
8660 "Create standard functions for minor mode.
8664 FUNC-MIN-SYM symbol, the name of the function that is created.
8667 DOC-STR string, the function documentation string
8669 INSTALL-FUNC symbol, if func-min-sym isn't in `minor-mode-alist', this
8670 function is called to install the minor mode.
8672 MODE-VAR symbol, a variable which turns minor mode on or off
8673 MODE-NAME symbol, a variable, contains mode name.
8674 [PREFIX-VAR] symbol, a variable, mode's prefix key. Can be nil
8675 [MENU-VAR] symbol, a variable, mode's menu definitions. The menu must be
8676 in format of easy-menu.el so that it is Emacs and
8679 [NO-MODE-MSG] if non-nil, then default mode turn on or off message
8680 is not displayed. The default message is
8681 'MODE-DESC mode minor mode is ON. Prefix key is XXX'
8682 MODE-DESC string, used in the default turn on message, see above.
8684 [HOOK] symbol, hook that is run when mode is called.
8686 [BODY] Lisp code to be added inside middle body. Can be nil.
8688 Created function's arguments:
8690 (&optional arg verb)
8691 ARG is mode on off variable. nil toggles mode.
8692 VERB is set in interactive call and controlls printing mode
8693 turn on or off message. If nil, then no messages are
8696 Example how to use this macro:
8698 ;;; We have to inform autoload that function exist after macro
8699 ;;;###autoload (autoload 'xxx-mode \"package-file\" t t)
8701 (ti::macrof-minor-mode
8703 \"XXX minor mode. This helps you to do ....
8706 \\\\{xxx-mode-prefix-map}
8711 xxx-:mode-prefix-key
8712 nil ;; no menu variables
8719 (message \"Hey!\")))
8721 Example how to call created functions:
8723 (xxx-mode) ;; toggles
8725 (xxx-mode 0) ;; off, could also be -1
8726 (turn-on-xxx-mode) ;; function can be put to hook
8727 (turn-off-xxx-mode)"
8729 (ti::macrof-minor-mode-1
8745 ;;; ----------------------------------------------------------------------
8747 (defun ti::macrof-minor-mode-1
8762 "Use macro `ti::macrof-minor-mode'. And see arguments there.
8763 FUNC-MIN-SYM DOC-STR INSTALL-FUNC MODE-VAR
8764 MODE-NAME PREFIX-VAR MENU-VAR NO-MODE-MSG MODE-DESC
8767 ;;; (ti::d!! "\n\n" body)
8769 (intern (symbol-name (` (, func-min-sym)))))
8771 (intern (concat (symbol-name (` (, func-min-sym)))
8775 (&optional arg verb)
8779 (if (null (assq (quote (, func-min-sym)) minor-mode-alist))
8781 ;;; (let* ((val (symbol-value (, mode-var)))
8783 ;;; (setq (, mode-var) (ti::bool-toggle val arg)))
8784 (ti::bool-toggle (, mode-var) arg)
8785 ;; XEmacs needs this call, in emacs turning on the minor
8786 ;; mode automatically adds the menu too.
8788 ;;; (if (symbol-value (, mode-var))
8789 ;;; (easy-menu-add (symbol-value (, menu-var)))
8790 ;;; (easy-menu-remove (symbol-value (, menu-var))))
8791 (if (and (, mode-var)
8793 ;; easy-menu-add dies if menu-var is nil
8794 (easy-menu-add (, menu-var))
8795 (easy-menu-remove (, menu-var)))
8797 (funcall (quote (, viper-sym))))
8799 (ti::compat-modeline-update)
8800 (if (and verb (null (, no-mode-msg)))
8802 "%s minor mode is %s %s"
8804 (if (, mode-var) "on." "off.")
8805 (if (null (, mode-var))
8808 (format "Prefix key is %s" (, prefix-var))
8810 (run-hooks (quote (, hook)))
8811 ;; Return status of minor mode as last value.
8814 ;;; ----------------------------------------------------------------------
8816 (defun ti::macrof-minor-mode-on (mode-func-sym)
8817 "Create standard function to turn on the minor mode MODE-FUNC-SYM."
8819 (intern (concat "turn-on-" (symbol-name (` (, mode-func-sym)))))))
8822 "Turn minor mode on"
8824 ((, mode-func-sym) 1)))))
8826 ;;; ----------------------------------------------------------------------
8828 (defun ti::macrof-minor-mode-off (mode-func-sym)
8829 "Create standard function to turn off the minor mode MODE-FUNC-SYM."
8831 (intern (concat "turn-off-" (symbol-name (` (, mode-func-sym)))))))
8834 "Turn minor mode off"
8836 ((, mode-func-sym) -1)))))
8838 ;;; ----------------------------------------------------------------------
8840 (defun ti::macrof-minor-mode-help (mode-func-sym)
8841 "Create standard function to print MODE-FUNC-SYM function's destription."
8842 (let* ((sym (intern (concat (symbol-name (` (, mode-func-sym))) "-help"))))
8847 (with-output-to-temp-buffer "*help*"
8848 (princ (documentation (quote (, mode-func-sym)))))))))
8850 ;;; ----------------------------------------------------------------------
8852 (defun ti::macrof-minor-mode-commentary (pfx mode-func-sym)
8853 "Create standard function to print PFX MODE-FUNC-SYM Commentary."
8854 (let* ((name pfx) ;; (symbol-name (` (, mode-func-sym))))
8855 (sym (intern (concat name "commentary")))
8856 (file1 (substring pfx 0 (1- (length name))))
8857 (file2 (concat file1 ".el")))
8860 "Display `finder-commentary'."
8862 ;; Same as what `finde-commentary' uses
8863 ;; One problem: lm-commentary has a bug, which causes killing
8864 ;; the file from emacs after it's done. But we don't want that
8865 ;; if use is viewing or loaded it to emacs before us.
8867 ;; Work around that bug.
8869 (get-buffer (, file2))
8870 (find-buffer-visiting (, file2))
8871 (find-buffer-visiting (, file1)))))
8873 (finder-commentary (, file2))
8874 ;; This is only a pale emulation....will do for now.
8876 (with-current-buffer buffer
8877 (setq str (lm-commentary))
8878 (with-current-buffer (ti::temp-buffer "*Finder*" 'clear)
8880 (ti::pmin) (ti::buffer-replace-regexp "^;+" 0 "")
8881 (ti::pmin) (ti::buffer-replace-regexp "\r" 0 "")
8882 (display-buffer (current-buffer)))))))))))
8884 ;;; ----------------------------------------------------------------------
8886 (defun ti::macrof-minor-mode-viper-attach (pfx mode-func-sym)
8887 "Create standard function PFX MODE-FUNC-SYM to attach mode to viper."
8888 (let* ((name pfx) ;; (symbol-name (` (, mode-func-sym))))
8889 (sym (intern (concat (symbol-name (` (, mode-func-sym)))
8891 (file1 (substring pfx 0 (1- (length name)))))
8894 "Attach minor mode to viper with `viper-harness-minor-mode'."
8895 (if (featurep 'viper)
8896 (ti::funcall 'viper-harness-minor-mode (, file1)))))))
8898 ;;; ----------------------------------------------------------------------
8900 (defmacro ti::macrof-minor-mode-install
8908 "Return standard function form.
8909 Returned function will install and remove minor mode.
8913 FUNC-INS-SYM symbol, the name of the function that is created.
8914 E.g. 'xxx-install-mode
8916 MODE-SYM function symbol to call to run the mode e.g. 'xxx-mode
8918 MAP-SYM mode's keymap symbol. E.g. 'xxx-mode-map
8920 MODE-NAME-SYM mode's name symbol. E.g. 'xxx-mode-name
8922 HOOK-SYM hook symbol to call when mode has been installed.
8923 e.g. 'xxx-key-define-hook, which calls necessary
8924 functions to install keys and menus.
8926 BODY Lisp forms executed in the beginning of function.
8928 Created function's arguments:
8930 (&optional remove verb)
8931 REMOVE uninstall minor mode
8932 VERB is set for interactive calls: non-nil allows
8933 displaying messages.
8935 How to call this function:
8937 (ti::macrof-minor-mode-install
8943 xxx-:mode-define-keys-hook
8948 Example how to call created function:
8950 M -x xxx-install-mode ;; this calls created function and installs mode
8951 (xxx-install-mode) ;; Same
8952 (xxx-install-mode 'remove) ;; Or prefix ARG, removes the minor mode"
8953 (` (, (ti::macrof-minor-mode-install-1
8962 ;;; ----------------------------------------------------------------------
8964 (defun ti::macrof-minor-mode-install-1
8973 "Use macro `ti::macrof-minor-mode-install'. See arguments there.
8974 FUNC-INS-SYM MODE-SYM MAP-SYM MODE-NAME-SYM HOOK-SYM BODY"
8975 (let* ((sym (intern (symbol-name (` (, func-ins-sym))))))
8977 (defun (, sym) (&optional remove verb)
8978 "Install or optionally REMOVE minor mode. Calling this always
8979 removes old mode and does reintall."
8985 (ti::keymap-add-minor-mode '(, mode-sym) nil nil 'remove)
8987 (message "minor mode removed")))
8989 (setq (, map-sym) (make-sparse-keymap)) ;; always refresh
8990 (setq (, prefix-map-sym) (make-sparse-keymap)) ;; always refresh
8991 (run-hooks '(, hook-sym))
8992 ;; Always do reinstall; because keymaps stored permanently and
8993 ;; making a change later is impossible.
8994 (ti::keymap-add-minor-mode '(, mode-sym) nil nil 'remove)
8995 (ti::keymap-add-minor-mode '(, mode-sym)
8999 (message "minor mode installed"))))))))
9001 ;;; ----------------------------------------------------------------------
9003 (defmacro ti::macrof-define-keys
9015 "Return standard function form.
9016 The returned function will install keymaps and menu-bar menu for minor mode.
9018 Inside the function you can refer to variables
9020 'root-map' refers to ROOT keymap from where the prefix map is accessed
9021 This is the original keymap where the PREFIX-KEY is
9022 assigned. The actual commands are put to 'map'.
9023 'map' refers to separate minor mode prefix keymap
9024 'p' holds the prefix key.
9028 MINOR--MODE-NAME string
9029 MINOR--MODE-DESC string
9030 FUNC-DEF-SYM symbol, function name which is created
9031 KEYMAP-SYM symbol, keymap where to define keys, must exist
9032 PREFIX-KEY-SYM symbol, variable holding the prefix key.
9033 [EASYMENU-SYM] symbol, easy menu variable or nil.
9034 [EASYMENU-NAME-SYM] symbol, easy menu's menu-bar name variable or nil
9035 [EASYMENU-DOC-STR] string, Describe string for menu.
9036 [EASY-MENU-FORMS] forms to define menus
9037 EVAL-BODY forms executed at the end of function.
9039 Created function's arguments:
9043 How to call this function:
9045 (ti::macrof-define-keys
9046 xxx-mode-define-keys
9047 xxx-:mode-prefix-map
9048 xxx-:mode-prefix-key
9050 xxx-:mode-easymenu-name
9052 xxx-:mode-easymenu-name
9053 [\"menu item1\" xxx-function1 t]
9054 [\"menu item2\" xxx-function2 t]
9056 [\"menu item3\" xxx-function3 t])
9058 (define-key map \"a\" 'xxx-function1)
9059 (define-key map \"b\" 'xxx-function2)
9060 (define-key map \"c\" 'xxx-function3)))
9062 Example how to call created function:
9064 (xxx-mode-define-keys)"
9065 (` (, (ti::macrof-define-keys-1
9078 ;;; ----------------------------------------------------------------------
9080 (defmacro ti::macrov-mode-line-mode-menu (mode-symbol text)
9081 "Add MODE-SYMBOL to minor mode list in Emacs mode line menu."
9082 (let ((sym (vector (intern (symbol-name (` (, mode-symbol)))))))
9083 (` (when (boundp 'mode-line-mode-menu) ;; Emacs 21.1
9084 (define-key mode-line-mode-menu (, sym)
9085 '(menu-item (, text)
9087 :button (:toggle . (, mode-symbol))))))))
9089 ;;; ----------------------------------------------------------------------
9091 (defun ti::macrof-define-keys-1
9103 "Use macro `ti::macrof-define-keys' and see arguments there.
9104 MODE-NAME FUNC-DEF-SYM KEYMAP-SYM PREFIX-KEYMAP-SYM PREFIX-KEY-SYM
9105 EASYMENU-SYM EASYMENU-NAME-SYM EASYMENU-DOC-STR EASY-MENU-FORMS
9108 (setq sym (intern (symbol-name (` (, func-def-sym)))))
9111 (let* ((root-map (, keymap-sym))
9112 (map (, prefix-keymap-sym))
9113 (p (, prefix-key-sym)))
9114 (when (stringp (, easymenu-doc-str)) ;This could be nil (no menus)
9119 (, easymenu-doc-str)
9120 (, easy-menu-forms))
9124 (, easymenu-doc-str)
9125 (, easy-menu-forms))))
9126 ;; This is no-op, ByteComp silencer.
9127 ;; ** variable p bound but not referenced
9128 (if (null p) (setq p nil))
9129 (if (null map) (setq map nil))
9130 (if (null root-map) (setq root-map nil))
9131 (ti::macrov-mode-line-mode-menu
9132 (, minor--mode-name) (, minor--mode-desc))
9133 ;; (define-key mode-map mode-prefix-key mode-prefix-map)
9134 (when (, prefix-key-sym)
9138 (, prefix-keymap-sym)))
9139 ;; If you have selected a prefix key that is a natural ABC key;
9140 ;; then define "aa" as self insert command for "a" character.
9142 ;; check also if prefix key defined is like [{a)]] where "a"
9143 ;; if a single character. The [{?\C-a)]] is nto accepted as
9144 ;; repeated key: C-aC-a, only "aa"
9145 (let* ((char (ti::keymap-single-key-definition-p p)))
9146 (when (and (characterp char) (ti::print-p char))
9147 ;; The prefix key is single; printable character.
9148 (define-key map p 'self-insert-command)))
9151 ;;; ----------------------------------------------------------------------
9153 (defun ti::macrof-version-bug-report-1
9163 "Use macro `ti::macrof-version-bug-report' and see arguments there.
9164 FILENAME PREFIX VERSION-VARIABLE VERSION-VALUE
9165 BUG-VAR-LIST BUFFER-LIST BUG-BODY."
9172 'defconst (` (, version-variable))
9173 (` (, version-value))
9174 "Package's version information."))
9176 (setq sym (intern (format "%s-version" prefix)))
9180 (defun (, sym) (&optional arg)
9181 "Version information."
9183 (ti::package-version-info (, filename) arg))))
9185 (setq sym (intern (format "%s-submit-bug-report" prefix)))
9190 "Send bug report or feedback."
9192 (ti::package-submit-bug-report
9194 (, version-variable)
9202 ;;; ----------------------------------------------------------------------
9204 (defmacro ti::macrof-version-bug-report
9213 "Return standard function form.
9214 One variable and two functions are created.
9218 FILENAME string e.g. xxx.el
9219 PREFIX package prefix for functions e.g. xxx
9220 VERSION-VARIABLE symbol variable holding the version information.
9221 VERSION-VALUE value for the variable. Should be RCS Id string or the
9223 BUG-VAR-LIST variable list to send with bug report
9224 BUG-BODY Lisp forms for the bug function.
9226 How to call this macro:
9228 (ti::macrof-version-bug-report
9232 \"...version Id string here, RCS controlled.\"
9236 xxx-mode-define-keys-hook
9239 Example how to call created functions:
9241 M - x xxx-submit-bug-report
9243 (`(, (ti::macrof-version-bug-report-1
9252 ;;; ----------------------------------------------------------------------
9254 (defun ti::macrof-debug-1
9257 debug-toggle-function
9258 debug-buffer-show-function
9261 "Use macro `ti::macrof-debug' and see argument there.
9263 DEBUG-FUNCTION DEBUG-TOGGLE-FUNCTION DEBUG-BUFFER-SHOW-FUNCTION
9264 DEBUG-VARIABLE DEBUG-BUFFER."
9272 'defvar (` (, debug-variable))
9274 "Debug control: on or off."))
9279 'defvar (` (, debug-buffer))
9280 (format "*%s-debug*" prefix)
9281 "Debug output buffer."))
9286 "Prefix ARG: nil = toggle, 0 = off, 1 = on."))
9290 (defun (, debug-toggle-function) (&optional arg)
9293 (let* ((buffer (get-buffer (, debug-buffer))))
9294 (ti::bool-toggle (, debug-variable) arg)
9295 (when (and (, debug-variable)
9297 (y-or-n-p "Clear debug buffer?"))
9298 (ti::erase-buffer buffer))
9300 (message "Debug is %s"
9301 (if (, debug-variable)
9305 (when debug-buffer-show-function
9306 (setq str "Show debug buffer.")
9310 (defun (, debug-buffer-show-function) (&optional arg)
9313 (let* ((buffer (get-buffer (, debug-buffer))))
9314 (ti::bool-toggle (, debug-variable) arg)
9316 (message "There is no debug buffer to show.")
9317 (display-buffer buffer))))))
9320 (concat "Write debug log to " ;; (` (, debug-buffer ))
9322 ;;; (symbol-name (quote (` (, debug-variable)) ))
9325 ;; We are returning a macro in next elt.
9329 (defmacro (, debug-function) (&rest args)
9330 ;;; (when (, debug-variable)
9331 ;;; (let* ((ti:m-debug-buffer (, debug-buffer )))
9332 (when (, debug-variable)
9333 (with-current-buffer (get-buffer-create (, debug-buffer))
9334 (goto-char (point-max))
9336 (insert (format "|%s" (eval (pop args)))))
9341 ;;; ----------------------------------------------------------------------
9343 (defmacro ti::macrof-debug-lowlevel
9346 debug-toggle-function
9347 debug-buffer-show-function
9350 "Return standard function forms for debug interface.
9351 One variable, one function and one macro will be created.
9355 PREFIX string, symbols' prefix.
9356 DEBUG-FUNCTION symbol, function name to generate debug
9357 DEBUG-TOGGLE-FUNCTION symbol, function name to turn on/off debug
9358 DEBUG-BUFFER-SHOW-FUNCTION symbol, fucntion to display debug buffer.
9359 DEBUG-VARIABLE symbol, variable to control debug
9360 DEBUG-BUFFER string, buffer name where to write debug.
9362 How to call this macro:
9364 (ti::macrof-debug xxx-debug xxx-debug-toggle xxx-debug-show
9365 xxx-debug \"*xxx-debug*\")
9367 Example how to call created functions:
9369 M - x xxx-debug-show
9371 M - x xxx-debug-toggle ;; To turn on or off debug package debug
9372 (xxx-debug-toggle 0) ;; off
9373 (xxx-debug-toggle 1) ;; on
9375 ;; To generate debug from inside code, you call:
9376 (xxx-debug ... anything frame-pointer buffer-pointer ...)"
9377 (`(, (ti::macrof-debug-1
9380 debug-toggle-function
9381 debug-buffer-show-function
9385 ;;; ----------------------------------------------------------------------
9387 (defmacro ti::macrof-debug-standard (prefix &optional var-prefix)
9388 "Make standard debug interface according to PREFIX and VAR-PREFIX."
9389 (let* ((d-func (intern (format "%s-debug" prefix)))
9390 (dt-func (intern (format "%s-debug-toggle" prefix)))
9391 (ds-func (intern (format "%s-debug-show" prefix)))
9392 (pfx (or var-prefix "-"))
9393 (d-var (intern (format "%s%sdebug" prefix pfx)))
9394 (d-buffer (intern (format "%s%sdebug-buffer" prefix pfx))))
9395 (`(, (ti::macrof-debug-1
9403 ;;; ----------------------------------------------------------------------
9405 (defun ti::macrof-install-pgp-tar-1
9406 (func-ins-sym elisp-file &optional log-buffer)
9407 "Use macro `ti::macrof-install-pgp-tar' and see arguments there.
9408 FUNC-INS-SYM ELISP-FILE LOG-BUFFER."
9411 (setq sym (intern (symbol-name (` (, func-ins-sym)))))
9414 (defun (, sym) (dir)
9415 "Install additional programs from the end of package."
9416 (interactive "DSave programs to directory: ")
9417 (let* ((file (, elisp-file))
9418 (source (or (locate-library file)
9419 (error "can't find %s along load-path." file))))
9420 (ti::package-install-pgp-tar
9426 ;;; ----------------------------------------------------------------------
9428 (defmacro ti::macrof-install-pgp-tar
9429 (func-ins-sym elisp-file &optional log-buffer)
9430 "Return standard pgp tar install function.
9431 It handles installing pgp base 64 signed tar block from the end of file.
9433 1. Create tar file (it sould not have directory names, but ...)
9434 2. pgp base64 sign the tar file (clearsig off)
9435 3. paste pgp data to to end of your lisp package
9437 ;; -----BEGIN PGP MESSAGE-----
9440 ;; owHsWc1vG0l2n0GwwYjA3pJLgEXKlNaSDJLilySblrWWLXrMrCQrpOydzcxA02wW
9442 ;; -----END PGP MESSAGE-----
9444 And nothing more is needed to get your programs untarred nicely.
9445 The drop directory is asked from the user when he calls this function.
9449 FUNC-INS-SYM symbol, the created install function name
9450 ELISP-FILE your Lisp package name (with .el)
9451 [LOG-BUFFER] where to print the install log. Can be nil.
9453 Created function's arguments:
9456 DIR Where to untar the included file, asked interactively
9458 How to call this function:
9460 ;;;###autoload (autoload 'xxx-install-programs \"package-file\" t t)
9462 (ti::macrof-install-pgp-tar
9463 xxx-install-programs
9465 \"*xxx-install-log*\"))
9467 Example how to call created function:
9469 M - x xxx-install-programs"
9470 (` (, (ti::macrof-install-pgp-tar-1
9475 ;;; ----------------------------------------------------------------------
9477 (defmacro ti::macrof-minor-mode-wizard
9480 mode-Name-prefix-key ;
9491 define-key-body) ;12
9492 "Do all the necessary things to create minor mode.
9493 Following macros are called one by one. If you want personalized
9494 minor mode control, call each of these individually and don't use
9497 `ti::macrov-minor-mode'
9498 `ti::macrof-minor-mode-install'
9499 `ti::macrof-minor-mode'
9500 `ti::macrof-minor-mode-on'
9501 `ti::macrof-minor-mode-off'
9502 `ti::macrof-minor-mode-help'
9503 `ti::macrof-define-keys'
9508 MODE-NAME See -vmacro-
9509 MODE-NAME-PREFIX-KEY See -vmacro-
9510 EASYMENU-NAME See -vmacro-
9511 CUSTOM-GROUP See -vmacro-
9512 VARIABLE-STYLE See -vmacro-
9514 DOC-STR See -fmacro-minor-mode
9515 MODE-DESC See -fmacro-minor-mode
9516 MINOR-MODE-BODY See -fmacro-minor-mode must be in format ((BOBY))
9518 EASYMENU-DOC See -fmacro-define-keys must be in format ((BOBY))
9519 EASYMENU-BODY See -fmacro-define-keys must be in format ((BOBY))
9520 DEFINE-KEY-BODY See -fmacro-define-keys
9522 How to call this function:
9524 See example tinylisp.el package which uses this function to create
9527 If you want to see what this macro produces, use
9529 (macroexpand '(ti::macrof-minor-mode-wizard ...))C - x C - e
9531 Here is example how you would define the minor mode.
9533 (eval-and-compile ;; So that defvars and defuns are seen
9534 (ti::macrof-minor-mode-wizard
9535 \"xxx-\" ;; prefix for variables and functions
9536 \" xxxModeline\" ;; Modeline name
9537 \"\\C-cx\" ;; prefix key for mode.
9538 \"xxxMenubar\" ;; Menu bar name
9539 nil ;; <forget this>
9541 \"XXX minor mode. Does fancy things.\" ;; mode description
9543 \"XXX help\" ;; message displayed when user calls mode
9545 ;; ............................................................
9547 ;; Run body-of-code when minor mode is called
9550 ;; ............................................................
9551 ;; Next id used by easy-menu.el and defines menu items.
9553 xxx-mode-easymenu-name
9554 [\"Eval whole buffer\" xxx-eval-current-buffer t]
9557 ;; ............................................................
9558 ;; this block defines keys to the mode. The mode minor map is
9559 ;; locally bound to 'map' symbol.
9561 (define-key map \"-\" 'xxx-eval-current-buffer)
9562 (define-key map \"=\" 'xxx-calculate))))
9565 (ti::macrof-minor-mode-wizard-1
9568 mode-Name-prefix-key ;
9579 define-key-body)))) ;12
9581 ;;; ----------------------------------------------------------------------
9583 (defun ti::macrof-minor-mode-wizard-1
9586 mode-Name-prefix-key ;3
9597 define-key-body) ;12
9598 "Use macro `ti::macrof-minor-mode-wizard' and see parameters there.
9601 MODE-NAME-PREFIX-KEY
9623 (ti::nconc ret 'eval-and-compile)
9624 ;; ........................................... create variables ...
9626 (ti::macrov-minor-mode-1
9629 mode-Name-prefix-key
9633 (setq vs (if variable-style
9636 ;;; (ti::d!! "\n\n>>" elt)
9638 ;; .................................... create install function ...
9639 (setq sym1 (intern (concat pfx "install-mode"))
9640 sym2 (intern (concat pfx "mode"))
9641 sym3 (intern (concat vs "mode-map"))
9642 sym4 (intern (concat vs "mode-prefix-map"))
9643 sym5 (intern (concat vs "mode-name"))
9644 sym6 (intern (concat vs "mode-define-keys-hook")))
9645 ;;; (ti::d!! "\n\n>>minor-mode-install" sym1 sym2 sym3 sym4 sym5 "\n")
9646 (setq elt (ti::macrof-minor-mode-install-1
9647 sym1 sym2 sym3 sym4 sym5 sym6))
9649 ;; ....................................... define keys function ...
9650 (setq sym1 (intern (concat pfx "mode-define-keys"))
9651 sym2 (intern (concat vs "mode-map"))
9652 sym3 (intern (concat vs "mode-prefix-map"))
9653 sym4 (intern (concat vs "mode-prefix-key"))
9654 sym5 (intern (concat vs "mode-easymenu"))
9655 sym6 (intern (concat vs "mode-easymenu-name"))
9656 sym7 (intern (concat pfx "mode")))
9657 ;;; (ti::d!! "\n\n>>define-keys" sym1 sym2 sym3 sym4 sym5)
9659 (ti::macrof-define-keys-1
9672 ;; ................................. create minor mode function ...
9673 (setq sym1 (intern (concat pfx "mode"))
9674 sym2 (intern (concat pfx "install-mode"))
9675 sym3 (intern (concat pfx "mode"))
9676 sym4 (intern (concat vs "mode-name"))
9677 sym5 (intern (concat vs "mode-prefix-key"))
9678 sym6 (intern (concat vs "mode-easymenu"))
9679 sym7 (intern (concat vs "mode-hook")))
9680 ;;; (ti::d!! "\n\n>>minor-mode" sym1 sym2 sym3 sym4 sym5 sym6 sym7 "\n")
9682 (ti::macrof-minor-mode-1
9689 (setq elt (ti::macrof-minor-mode-on sym1))
9691 (setq elt (ti::macrof-minor-mode-off sym1))
9693 (setq elt (ti::macrof-minor-mode-help sym1))
9695 (setq elt (ti::macrof-minor-mode-commentary pfx sym1))
9697 (setq elt (ti::macrof-minor-mode-viper-attach pfx sym1))
9705 ;;; tinylib.el ends here