OSDN Git Service

c106dc905c4c91d146f3696e3a352e8e21d07308
[howm/howm.git] / howm-common.el
1 ;;; howm-common.el --- Wiki-like note-taking tool
2 ;;; Copyright (C) 2002, 2003, 2004, 2005-2018
3 ;;;   HIRAOKA Kazuyuki <khi@users.osdn.me>
4 ;;;
5 ;;; This program is free software; you can redistribute it and/or modify
6 ;;; it under the terms of the GNU General Public License as published by
7 ;;; the Free Software Foundation; either version 1, or (at your option)
8 ;;; any later version.
9 ;;;
10 ;;; This program is distributed in the hope that it will be useful,
11 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
13 ;;; GNU General Public License for more details.
14 ;;;
15 ;;; The GNU General Public License is available by anonymouse ftp from
16 ;;; prep.ai.mit.edu in pub/gnu/COPYING.  Alternately, you can write to
17 ;;; the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139,
18 ;;; USA.
19 ;;--------------------------------------------------------------------
20
21 (require 'howm-vars)
22
23 (defun howm-cl-remove-duplicates* (&rest args)
24   ":from-end version of `remove-duplicates'"
25   (apply #'cl-remove-duplicates `(,@args :from-end t)))
26
27 (defun howm-sort (evaluator comparer obj-list)
28   (let* ((orig (mapcar (lambda (obj) (cons (funcall evaluator obj) obj))
29                        obj-list))
30          (sorted (sort orig (lambda (x y)
31                               (funcall comparer (car x) (car y))))))
32     (mapcar #'cdr sorted)))
33
34 (defun howm-subdirectory-p (dir target &optional strict)
35   "For the directory DIR, check whether TARGET is under it.
36 When TARGET and DIR are same, (not STRICT) is returned."
37   (and (stringp dir)
38        ;; avoid unnecessary password prompting
39        ;; (I'm not sure about the return value of file-remote-p.)
40        (eq (not (file-remote-p dir)) (not (file-remote-p target)))
41        (progn
42          (setq target (howm-normalize-file-name target))
43          (setq dir (howm-normalize-file-name dir))
44          (if (string= target dir)
45              (not strict)
46            (and (string-match (regexp-quote dir) target)
47                 (= 0 (match-beginning 0)))))))
48
49 (defun howm-normalize-file-name (filename)
50   (let* ((r (file-remote-p filename))
51          (f (if r
52                 (concat r filename)
53               (file-truename (expand-file-name filename)))))
54     ;; for meadow
55     (if (string-match "^[A-Z]:" f)
56         (let ((drive (substring f 0 1))
57               (rest (substring f 1)))
58           (concat (downcase drive) rest))
59       f)))
60
61 (defvar howm-abbreviate-file-name t)
62 (defun howm-abbreviate-file-name (f)
63   (if (howm-abbreviate-file-name-p)
64       (abbreviate-file-name f)
65     f))
66 ;; for compatibility (incomplete)
67 (howm-dont-warn-free-variable howm-template-file-abbrev)
68 (howm-dont-warn-free-variable howm-view-header-abbrev)
69 (defun howm-abbreviate-file-name-p ()
70   (cond ((boundp 'howm-template-file-abbrev) howm-template-file-abbrev)
71         ((boundp 'howm-view-header-abbrev) howm-view-header-abbrev)
72         (t howm-abbreviate-file-name)))
73 ;; (defun howm-abbreviate-file-name-p () howm-abbreviate-file-name)
74
75 (defun howm-expand-file-names (file-list)
76   (mapcar (lambda (f) (directory-file-name (expand-file-name f)))
77           file-list))
78
79 (defun howm-insert-file-contents (file)
80   (insert-file-contents file nil nil howm-view-contents-limit))
81
82 ;;; for XEmacs fallback
83 ;; (if (not (fboundp 'font-lock-fontify-block))
84 ;;     (defalias 'font-lock-fontify-block 'font-lock-fontify-buffer))
85 ;;; If you use APEL, you can replace a below block with (require 'poe).
86 (if (not (fboundp 'line-beginning-position))
87     (defalias 'line-beginning-position 'point-at-bol))
88 (if (not (fboundp 'line-end-position))
89     (defalias 'line-end-position 'point-at-eol))
90 ;;; Imported from APEL 10.6
91 (if (not (fboundp 'match-string-no-properties))
92     ;; Emacs 20.3 and later: (match-string-no-properties NUM &optional STRING)
93     (defun match-string-no-properties (num &optional string)
94       "Return string of text matched by last search, without text properties.
95 NUM specifies which parenthesized expression in the last regexp.
96  Value is nil if NUMth pair didn't match, or there were less than NUM pairs.
97 Zero means the entire text matched by the whole regexp or whole string.
98 STRING should be given if the last search was by `string-match' on STRING."
99       (if (match-beginning num)
100           (if string
101               (let ((result
102                      (substring string (match-beginning num) (match-end num))))
103                 (set-text-properties 0 (length result) nil result)
104                 result)
105             (buffer-substring-no-properties (match-beginning num)
106                                             (match-end num))))))
107
108 (defmacro howm-message-time (name &rest body)
109   (declare (indent 1))
110   `(let ((howm-message-time-0 (current-time)))
111      (prog1
112          (progn
113            ,@body)
114        (when howm-message-time
115          (message "%s (%s: %.2f sec)"
116                   (or (current-message) "")
117                   ,name
118                   (howm-time-difference-second (current-time)
119                                                howm-message-time-0))))))
120 ;; (defun howm-message-time-from (ti0)
121 ;;   (when howm-message-time
122 ;;     (let ((ti1 (current-time)))
123 ;;       (message "took %.2f sec."
124 ;;                (howm-time-difference-second ti1 ti0)))))
125 (defun howm-time-difference-second (ti1 ti0)
126   (let ((h (- (car ti1) (car ti0)))
127         (l (- (cadr ti1) (cadr ti0)))
128         (m (- (or (cl-caddr ti1) 0) (or (cl-caddr ti0) 0)))
129         )
130     (+ (* h 65536) l
131        (* m 1e-6)
132        )))
133
134 (defun howm-xor (a b)
135   (if a (not b) b))
136 (defun howm-buffer-empty-p (&optional buf)
137   ;; emacs20 doesn't have (buffer-size buf)
138   (with-current-buffer (or buf (current-buffer))
139     (= (buffer-size) 0)))
140 (defun howm-point-beginning-of-line ()
141   (save-excursion
142     (beginning-of-line)
143     (point)))
144 (defun howm-point-end-of-line ()
145   (save-excursion
146     (end-of-line)
147     (point)))
148
149 (defun howm-inhibit-warning-in-compilation (&rest dummy)
150   (error "This is dummy function to inhibit warning in compilation."))
151
152 ;; (defvar howm-reminder-quick-check-key ";")
153
154 (defun howm-get-value (z)
155   (if (functionp z)
156       (funcall z)
157     z))
158
159 ;; (howm-map-with-index #'cons '(a b c)) ==> ((a . 0) (b . 1) (c . 2))
160 (defun howm-map-with-index (f seq)
161   "Map with index. For example, 
162 (howm-map-with-index #'cons '(a b c)) returns ((a . 0) (b . 1) (c . 2))."
163   (let ((howm-map-with-index-count -1))
164     (mapcar (lambda (x)
165               (setq howm-map-with-index-count (1+ howm-map-with-index-count))
166               (apply f (list x howm-map-with-index-count)))
167             seq)))
168
169 (defun howm-capital-p (str)
170   "Return nil iff STR has no capital letter."
171   (let ((case-fold-search nil)) 
172     (string-match "[A-Z]" str)))
173
174 (defun howm-single-element-p (a)
175   (and a (null (cdr a))))
176
177 (defun howm-read-string (prompt &optional immediate-chars continued-chars
178                                 pass-through pass-ret-through)
179   "Read a string from minibuffer with some extensions to `read-string'.
180 (1) When the first input char is in IMMEDIATE-CHARS string,
181 this function returns the char as one letter string
182 without waiting for rest input and RET key.
183 (2) Otherwise, when the char is in CONTINUED-CHARS,
184 this function is equivalent to read-string.
185 (3) When the char is not in either IMMEDIATE-CHARS or CONTINUED-CHARS,
186 the behavior depends on PASS-THROUGH.
187 If PASS-THROUGH is nil, error is raised.
188 If PASS-THROUGH is non-nil, the input event is unread and nil is returned.
189 (4) Note that RET key at the first char is the special case.
190 If PASS-RET-THROUGH is nil, empty string is returned.
191 If PASS-RET-THROUGH is non-nil, RET is unread and nil is returned.
192 "
193   (if (null immediate-chars)
194       (read-string prompt)
195     (save-window-excursion
196       (message "%s" prompt)
197       (select-window (minibuffer-window))
198       (let* ((ev (howm-read-event))
199              (ch (howm-event-to-character ev)))
200         (cond ((howm-characterp ch)
201                (howm-read-string-sub ev ch
202                                      prompt immediate-chars continued-chars
203                                      pass-through pass-ret-through))
204               (t
205                (howm-read-string-fail ev pass-through pass-ret-through)))))))
206
207 (defun howm-read-string-sub (event char
208                              prompt immediate-chars continued-chars
209                              pass-through pass-ret-through)
210   (let* ((ichars (string-to-list (or immediate-chars "")))
211          (cchars (string-to-list (or continued-chars "")))
212          (first-char char)
213          (first-str (char-to-string first-char)))
214     (cond ((member first-char ichars)
215            first-str)
216           ((member first-char cchars)
217            (read-string prompt (cons first-str (1+ (length first-str)))))
218           (t
219            (howm-read-string-fail event pass-through pass-ret-through)))))
220
221 (defun howm-read-string-fail (event pass-through pass-ret-through)
222   (cond ((and (howm-ret-key-event-p event) (not pass-ret-through))
223          "")
224         (pass-through
225          (progn
226            (howm-unread-event event)
227            nil))
228         (t
229          (error "Invalid input."))))
230
231 (defun howm-unread-event (event)
232   (setq unread-command-events
233         (cons event unread-command-events)))
234
235 (defun howm-first-n (seq n)
236   "Return the subsequence of SEQ from start to N-th item.
237 (howm-first-n '(a b c d e) 3) ==> (a b c)
238 (howm-first-n '(a b c d e) 10) ==> (a b c d e)
239 "
240   ;; GNU emacs: (subseq '(a b c d e) 0 7) ==> (a b c d e nil nil)
241   ;; xemacs:    (subseq '(a b c d e) 0 7) ==> Args out of range
242   (if (<= (length seq) n)
243       seq
244     (cl-subseq seq 0 n)))
245
246 ;; check
247 (let ((seq '(a b c d e))
248       (qa '((0 . nil)
249             (4 . (a b c d))
250             (5 . (a b c d e))
251             (7 . (a b c d e)))))
252   (mapc (lambda (z)
253           (let ((ans (howm-first-n seq (car z))))
254             (when (not (equal ans (cdr z)))
255               (error "howm-first-n is wrong: %s for %s" ans z))))
256         qa))
257
258 (defun howm-replace-region (beg end val)
259   (delete-region beg end)
260   ;; `format' in xemacs doesn't keep text properties.
261   (insert (if (stringp val)
262               val
263             (format "%s" val))))
264
265 (defmacro howm-edit-read-only-buffer (&rest body)
266   (declare (indent 0))
267   `(progn
268      (buffer-disable-undo)
269      (setq buffer-read-only nil)
270      ,@body
271      (set-buffer-modified-p nil)
272      (setq buffer-read-only t)))
273
274 (defmacro howm-rewrite-read-only-buffer (&rest body)
275   (declare (indent 0))
276   `(howm-edit-read-only-buffer
277      (erase-buffer)
278      ,@body))
279
280 ;; (put 'howm-rewrite-read-only-buffer 'lisp-indent-hook 0)
281 ;; (defmacro howm-rewrite-read-only-buffer (&rest body)
282 ;;   `(progn
283 ;;      (setq buffer-read-only nil)
284 ;;      (erase-buffer)
285 ;;      ,@body
286 ;;      (set-buffer-modified-p nil)
287 ;;      (setq buffer-read-only t)))
288
289 (defun howm-get-buffer-for-file (file &optional buffer-name)
290   "Get buffer for FILE, and rename buffer if BUFFER-NAME is given."
291   ;; This may cause "File XXX no longer exists!" message if the file
292   ;; is deleted and the corresponding buffer still exists.
293   (let ((buf (find-file-noselect file)))
294     (when buffer-name
295       (with-current-buffer buf
296         (rename-buffer buffer-name)))
297     buf))
298
299 (defun howm-basic-save-buffer ()
300   "Silent version of `basic-save-buffer' without \"Wrote ...\" message."
301   (let ((original-write-region (symbol-function 'write-region)))
302     ;; make silent `write-region', which doesn't say "Wrote ...".
303     ;; I borrowed the idea from Okuyama's auto-save-buffers. thx.
304     ;; http://homepage3.nifty.com/oatu/emacs/misc.html
305     (cl-flet ((write-region (start end filename
306                                 &optional append visit lockname must)
307                          (funcall original-write-region
308                                   start end filename append
309                                   'dont-say-wrote-foobar
310                                   lockname must)))
311       (basic-save-buffer)))
312   ;; As a side effect, basic-save-buffer does not update buffer-modified-p.
313   (set-visited-file-modtime)
314   (set-buffer-modified-p nil))
315
316 (defvar howm-log-buffer-name-format " *howm-log:%s*")
317 (defun howm-write-log (message fmt file &optional limit remove-fmt)
318   "Write MESSAGE with format FMT to the top of FILE.
319 FORMAT must have two %s; the formar is time and the latter is message.
320 When LIMIT is non-nil, only that number of recent messages are recorded.
321 When REMOVE-FMT is non-nil, it is used to generate regular expression
322 to remove matched lines. REMOVE-FMT must have one %s."
323   (save-excursion
324     (let ((buffer-name (format howm-log-buffer-name-format
325                                (file-name-nondirectory file))))
326       (with-current-buffer (howm-get-buffer-for-file file buffer-name)
327         (goto-char (point-min))
328         (when remove-fmt
329           (save-excursion
330             (flush-lines (format remove-fmt (regexp-quote message)))))
331         (insert (format fmt
332                         (format-time-string howm-dtime-format (current-time))
333                         message)
334                 "\n")
335         (when limit
336           ;; Since I don't understand `selective-display' in goto-line,
337           ;; I avoid it.
338           (goto-char (point-min))
339           (when (= (forward-line limit) 0) ;; buffer lines > LIMIT
340             (delete-region (point) (point-max))))
341         (howm-basic-save-buffer)))))
342
343 (defun howm-get-symbol (soft &rest args)
344   "Return the canonical symbol for a specified name.
345 If SOFT is non-nil, return nil when the corresponding symbol does not exist.
346 Name of returned symbol is concatenation of ARGS.
347 Both strings and symbols are acceptable in ARGS."
348   (funcall (if soft #'intern-soft #'intern)
349            (mapconcat (lambda (s)
350                         (cond ((sequencep s) s)
351                               ((symbolp s) (symbol-name s))
352                               (t (error "Not supported: %S" s))))
353                       args
354                       "")))
355
356 ;; snap://Info-mode/elisp#Killing Buffers
357 (defun howm-buffer-killed-p (buffer)
358   "Return t if BUFFER is killed."
359   (not (buffer-name buffer)))
360
361 (defun howm-classify (classifier lis &optional reverse)
362   "Classify elements in given list.
363 CLASSIFIER is criterion of classification for list LIS.
364 If REVERSE is non-nil, order of elements are reversed (faster).
365 For example,
366   (howm-classify (lambda (s) (substring s 0 1)) '(\"aaa\" \"abc\" \"xyz\"))
367 returns ((\"a\" \"aaa\" \"abc\") (\"x\" \"xyz\"))."
368   (let ((ans nil))
369     (mapc (lambda (x)
370             (let* ((label (funcall classifier x))
371                    (pair (assoc label ans)))
372               (if (null pair)
373                   (setq ans (cons (cons label (list x)) ans))
374                 (setcdr pair (cons x (cdr pair))))))
375           lis)
376     (if reverse
377         ans
378       (reverse (mapcar (lambda (pair) (cons (car pair) (reverse (cdr pair))))
379                        ans)))))
380 ;; (howm-classify (lambda (s) (substring s 0 1)) '("aaa" "abc" "xyz"))
381
382 (defun howm-message-nolog (str &rest args)
383   (let ((message-log-max nil))
384     (apply #'message `(,str ,@args))))
385
386 (defun howm-decode-time (&optional specified-time)
387   "Decode SPECIFIED-TIME and remove DOW, DST, ZONE.
388 When we do something like (encode-time (decode-time)), we use this function
389 instead of the original `decode-time', so that we can force
390 current timezone rule uniformly to avoid inconsistency."
391   (butlast (decode-time specified-time) 3))
392
393 (defmacro howm-with-need (&rest body)
394   "Execute BODY where (need xxx) exits from this form if xxx is nil."
395   (declare (indent 0))
396   (let ((g (cl-gensym)))
397     `(catch ',g
398        (cl-labels ((need (x) (or x (throw ',g nil))))
399          ,@body))))
400
401 (defun howm-goto-line (n)
402   ;; see the document of `goto-line'
403   (goto-char (point-min)) (forward-line (1- n)))
404
405 ;; view-in-background
406
407 (defvar *howm-view-in-background* nil
408   "for internal use.
409 Don't set this variable directly.
410 Use `howm-view-in-background' and `howm-view-in-background-p' instead.")
411
412 (defmacro howm-view-in-background (&rest body)
413   "Obsolete. Do not use this any more."
414   (declare (indent 0))
415   `(let ((*howm-view-in-background* t))
416      ,@body))
417
418 (defun howm-view-in-background-p ()
419   *howm-view-in-background*)
420
421 ;;; history of search
422
423 (defvar howm-history-format "> %s | %s")
424 (defvar howm-history-remove-format "| %s$")
425
426 (defun howm-write-history (message)
427   (when (and howm-history-file
428              (or (null howm-history-limit) (> howm-history-limit 0)))
429     (howm-write-log message howm-history-format howm-history-file
430                     howm-history-limit
431                     (and howm-history-unique howm-history-remove-format))))
432
433 ;;; call process
434
435 (defvar howm-call-process-last-command nil
436   "List of arguments for last `howm-call-process'.
437 This variable exists only for debug. You can reproduce the last call
438 with the below code.
439  (apply #'howm-call-process howm-call-process-last-command)")
440
441 (defmacro howm-with-coding-system (coding-system &rest body)
442   "With CODING-SYSTEM, execute BODY.
443 examples:
444  (howm-with-coding-system 'euc-jp-unix ...)  ;; for both read and write
445  (howm-with-coding-system '(utf-8-unix . sjis-unix) ...)  ;; (read . write)
446  (howm-with-coding-system nil ...)  ;; howm-process-coding-system is used."
447   (declare (indent 1))
448   (let ((g (cl-gensym))
449         (cs (or coding-system 'howm-process-coding-system)))
450     `(let* ((,g ,cs)
451             (coding-system-for-read  (or (car-safe ,g) ,g))
452             (coding-system-for-write (or (cdr-safe ,g) ,g)))
453        ,@body)))
454
455 (defun howm-call-process (command args
456                                   &optional expected-return-value stdin-string)
457   (setq howm-call-process-last-command (list command args
458                                              expected-return-value
459                                              stdin-string))
460   (with-temp-buffer
461     (howm-with-coding-system nil
462       (let ((r (howm-call-process-here command args stdin-string)))
463         (when (and expected-return-value
464                    (not (= expected-return-value r)))
465           (error "Process returns %s instead of expected %s."
466                  r expected-return-value))
467         (howm-buffer-lines)))))
468
469 (defun howm-call-process-here (command args &optional stdin-string)
470   (let* ((beg (point))
471          (end (progn
472                 (insert (or stdin-string ""))
473                 (point)))
474          (a `(,beg ,end ,command t (t nil) nil ,@args)))
475     (howm-with-coding-system nil
476       (apply #'call-process-region a))))
477
478 (defun howm-buffer-lines (&optional buf)
479   (save-excursion
480     (when buf
481       (set-buffer buf))
482     (split-string (buffer-substring (point-min) (point-max)) "\n")))
483
484 (defun howm-call-process* (command common-args rest-args &rest options)
485   ;; (howm-call-process* "grep" '("pattern") '("001" ... "999"))
486   ;; is expanded to concatenation of
487   ;; (howm-call-process "grep" '("pattern" "001" ... "099"))
488   ;; (howm-call-process "grep" '("pattern" "101" ... "199"))
489   ;; ..., depending on howm-command-length-limit.
490   (cl-labels ((div (a limit measure)
491                 ;; (div '(3 1 4 1 5 9 2 6 5 3 5 8 9 7 9 3 2 3 8) 20 #'identity)
492                 ;; ==> ((3 1 4 1 5) (9 2 6) (5 3 5) (8 9) (7 9 3) (2 3 8))
493                 ;; [create new group when sum >= 20]
494                 (let ((sum limit) ;; measure >= 0 is assumed.
495                       (ans nil))
496                   (mapc (lambda (x)
497                           (let* ((w (funcall measure x))
498                                  (new-sum (+ sum w)))
499                             (if (< new-sum limit)
500                                 (setq sum new-sum
501                                       ans (cons (cons x (car ans)) (cdr ans)))
502                               (setq sum w
503                                     ans (cons (list x) ans)))))
504                         a)
505                   (reverse (mapcar #'reverse ans)))))
506     ;; XEmacs 21.4 lacks "string-bytes".
507     (let* ((len (symbol-function
508                  (cl-find-if #'fboundp '(string-bytes length))))
509            (limit (apply #'- howm-command-length-limit
510                          (mapcar len (cons command common-args))))
511            (as (div rest-args limit len)))
512       (cl-mapcan (lambda (args)
513                         (apply #'howm-call-process
514                                command (append common-args args) options))
515                       as))))
516
517 ;;; schedule-interval & reminder-setting (clean me)
518
519 (defvar howm-reminder-schedule-interval nil
520   "For internal use. Do not setq this variable.
521 Use `howm-with-schedule-interval' instead.")
522 (defun howm-reminder-schedule-interval-from ()
523   (car howm-reminder-schedule-interval))
524 (defun howm-reminder-schedule-interval-to ()
525   (cdr howm-reminder-schedule-interval))
526 (defmacro howm-with-schedule-interval (interval &rest body)
527   "Set the interval of visible schedule items in reminder list on menu.
528 INTERVAL is a form like (-1 2), which means 'from yesterday to the day
529 after tomorrow'. BODY is evaluated under this setting;
530 `howm-reminder-schedule-interval-from' returns -1 and
531 `howm-reminder-schedule-interval-to' returns 2."
532   (declare (indent 1))
533   `(let ((howm-reminder-schedule-interval ,(cons 'cons interval)))
534     ,@body))
535
536 (defmacro howm-with-reminder-setting  (&rest body)
537   (declare (indent 0))
538   `(howm-with-schedule-interval
539        (howm-menu-schedule-days-before howm-menu-schedule-days)
540      (let ((howm-todo-menu-types howm-reminder-menu-types))  ;; dirty!
541        ,@body)))
542
543 ;;; xemacs
544
545 ;; http://www.bookshelf.jp/cgi-bin/goto.cgi?file=meadow&node=switch%20config
546 ;; http://pc2.2ch.net/test/read.cgi/software/1056601345/510
547 (eval-and-compile
548   (defun howm-xemacsp ()
549     (featurep 'xemacs)))
550
551 (defmacro howm-defun-xemacs (func args emacs-f xemacs-f)
552   (declare (indent 'defun))
553   `(defun ,func ,args
554      ,(if (howm-xemacsp)
555           xemacs-f
556         emacs-f)))
557
558 (howm-defun-xemacs howm-deactivate-mark ()
559   (deactivate-mark)
560   (zmacs-deactivate-region))
561
562 (howm-defun-xemacs howm-read-event ()
563   (read-event)
564   ;; We have to skip #<magic-event Expose> when howm-action-lock-date is
565   ;; called (RET is hit on date format like [2005-10-15]) in menu buffer.
566   ;; 
567   ;; Though (make-event 'key-press `(key ,(read-char))) looks to be a simpler
568   ;; solution, it causes error when RET RET is hit in the above situation.
569   ;; I don't have enough time to examine it now.
570   (let ((ev (next-event)))
571     (if (key-press-event-p ev)
572         ev
573       (howm-read-event))))
574
575 ;; Though this function is used only once, I dare to define it
576 ;; with howm-defun-xemacs macro in order to avoid warning
577 ;; in byte-compilation on GNU emacs. I don't have enough energy now.
578 (howm-defun-xemacs howm-ret-key-event ()
579   (event-convert-list '(return))
580   (make-event 'key-press '(key return)))
581
582 (defvar howm-ret-key-event (howm-ret-key-event))
583
584 (defun howm-ret-key-event-p (event)
585   (or (equal event 13) (equal event howm-ret-key-event)))
586
587 (howm-defun-xemacs howm-event-to-character (event)
588   (and (howm-characterp event) event)
589   (event-to-character event))
590
591 (howm-defun-xemacs howm-characterp (x)
592   (numberp x)
593   (characterp x))
594
595 (defvar howm-infinity
596   (if (howm-xemacsp)
597       1.0e+100  ;; xemacs info on my machine is broken :(
598     1.0e+INF))
599
600 ;;; cl
601
602 ;; (defmacro howm-define-maybe (fname fargs &rest fbody)
603 ;;   (when (not (fboundp fname))
604 ;;     `(defun ,fname ,fargs
605 ;;        ,@fbody)))
606
607 ;; (howm-define-maybe caddr (x)
608 ;;                    (car (cdr (cdr x))))
609
610 ;; (howm-define-maybe second (x)
611 ;;                    (cadr x))
612
613 ;; (howm-define-maybe third (x)
614 ;;                    (caddr x))
615
616 ;;; regexp
617
618 ;; (defun howm-regexp-opt (strings &optional paren)
619 ;;   "Imitation of `regexp-opt' without optimization.
620 ;; This is used for large set of strings when `regexp-opt' causes an error
621 ;; \"Variable binding depth exceeds max-specpdl-size\"."
622 ;;   (let* ((open (if paren "\\(" ""))
623 ;;          (close (if paren "\\)" ""))
624 ;;          (re (concat open (mapconcat 'regexp-quote strings "\\|") close)))
625 ;;     (if (eq paren 'words)
626 ;;         (concat "\\<" re "\\>")
627 ;;       re)))
628
629 ;;; 
630
631 (provide 'howm-common)
632
633 ;;; howm-common.el ends here