howm-common.el

   1 ;;; howm-common.el --- Wiki-like note-taking tool
   2 ;;; Copyright (C) 2002, 2003, 2004, 2005-2020
   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, SUBSEC.
 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   (howm-first-n (decode-time specified-time) 6))
 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 (function 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