emacs_el/tiny-tools/tiny/tinylibb.el

   1 ;;; tinylibb.el --- Library of (b)ackward compatible functions.
   2
   3 ;; This file is not part of Emacs
   4
   5 ;;{{{ Id
   6
   7 ;; Copyright (C)    1998-2007 Jari Aalto
   8 ;; Keywords:        extensions
   9 ;; Author:          Jari Aalto
  10 ;; Maintainer:      Jari Aalto
  11 ;;
  12 ;; To get information on this program, call M-x tinylibb-version.
  13 ;; Look at the code with folding.el
  14
  15 ;; COPYRIGHT NOTICE
  16 ;;
  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)
  20 ;; any later version.
  21 ;;
  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
  25 ;; for more details.
  26 ;;
  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.
  31 ;;
  32 ;; Visit <http://www.gnu.org/copyleft/gpl.html> for more information
  33
  34 ;;}}}
  35 ;;{{{ Install
  36
  37 ;; ........................................................ &t-install ...
  38 ;; DO NOT LOAD THIS FILE, but load the central library "m". It loads this
  39 ;; file and autoload library "a"
  40 ;;
  41 ;;      (require 'tinylibm)
  42
  43 ;;}}}
  44 ;;{{{ Documentation
  45
  46 ;; ..................................................... &t-commentary ...
  47
  48 ;;; Commentary:
  49
  50 ;;  Preface, 1998
  51 ;;
  52 ;;      This is lisp function library, package itself does nothing.
  53 ;;      This library defines new [X]Emacs release functions for older
  54 ;;      [X]Emacs releases.
  55 ;;
  56 ;;  Usage
  57 ;;
  58 ;;      You must not autoload this package; but always include
  59 ;;
  60 ;;          (require 'tinylibm)
  61 ;;
  62 ;;      Yes, there is no typo, you load "m" lib. It will handle arranging
  63 ;;      everything for you. This library is included by "m" library
  64 ;;      automatically. Repeat: you DO NOT PUT any of these in your
  65 ;;      packages:
  66 ;;
  67 ;;          (require 'tinylib)
  68 ;;          (require 'tinyliba)
  69 ;;          (require 'tinylibb)
  70 ;;          (require 'tinylibo)
  71 ;;          (require 'tinyliby)
  72 ;;
  73 ;;      A single statement will arrange everything:
  74 ;;
  75 ;;          (require 'tinylibm)
  76 ;;
  77 ;;  Notes
  78 ;;
  79 ;;      2000-09-12 <ttn@revel.glug.org> in gnu.emacs.sources
  80 ;;      http://www.glug.org/people/ttn/software/ttn-pers-elisp/ reported that:
  81 ;;      New file core/veneration.el allows GNU Emacs 19 support.
  82 ;;      In this file some functions are available
  83 ;;      in GNU Emacs 20, but not in GNU Emacs 19: `compose-mail' and
  84 ;;      minimal supporting functions (see mail-n-news/compose-mail.el),
  85 ;;      `shell-command-to-string', and `char-before'. We also redefine
  86 ;;      `match-data' to handle arguments.
  87 ;;
  88 ;;      1998-10 SEMI's poe*el libraries also emulate various Emacs
  89 ;;      versions.
  90
  91 ;;}}}
  92
  93 ;;; Change Log:
  94
  95 ;;; Code:
  96
  97 ;;; .......................................................... provide ...
  98
  99 (require 'tinyliba)
 100 (provide 'tinylibb)
 101
 102 ;;{{{ code: Emacs compatibility, aliases, byteCompiler
 103
 104 (eval-and-compile
 105   (defvar temporary-file-directory)
 106   (autoload 'ti::replace-match "tinylibm"))
 107
 108 ;;; ....................................................... &emulation ...
 109
 110 (defun-maybe force-mode-line-update  ()
 111   ;; XEmacs, labels this obsolete
 112   ;; In older Emacs it does not exist
 113   (set-buffer-modified-p (buffer-modified-p)))
 114
 115 (defun-maybe eval-after-load (arg1 form) ;; XEmacs 19.14 doesn't have this
 116   ;;  "A simple emulation. Eval FORM immediately."
 117   (load arg1)
 118   (eval form))
 119
 120 ;; Some XEmacs doesn't have 'buffer-flush-undo
 121 (defalias-maybe 'buffer-disable-undo 'buffer-flush-undo)
 122
 123 (defalias-maybe 'number-to-string 'int-to-string)
 124
 125 (defalias-maybe 'set-text-properties 'ignore)
 126
 127 (defalias-maybe 'string-to-number 'string-to-int)
 128
 129 ;; Doesn't exist in Emacs
 130 (defalias-maybe 'read-directory-name 'read-file-name)
 131
 132 (and (fboundp 'insert-file-contents-literally)
 133      ;;  Emacs includes `insert-file-literally'.
 134      (defalias-maybe 'insert-file-literally 'insert-file-contents-literally))
 135
 136 (defun-maybe make-local-hook (hook) ;; Exists in 19.30+
 137   ;;  "Make HOOK local to buffer."
 138   ;; - I need locals so many times it make sme cry, e.g. post-command-hook
 139   ;; - And why doesn't the add-hook accepts list by default ??
 140   ;;
 141   ;; - This aapplies to 19.29.1 and newer
 142   ;;       (add-hook HOOK FUNCTION &optional APPEND LOCAL)
 143   ;;       Do not use `make-local-variable' to make a hook
 144   ;;       variable buffer-local.  Use `make-local-hook'
 145   ;;       instead.
 146   ;;
 147   ;; the variable may be local already, but we do not do
 148   ;; any checkings
 149   (make-local-variable hook)
 150   ;; Copy this because add-hook modifies the list structure.
 151   (set hook (copy-sequence (eval hook))))
 152
 153 (defun-maybe find-buffer-visiting (file) ;not in XEmacs 19.14
 154   ;;  "Find buffer for FILE."
 155   ;;   file-truename  dies if there is no directory part in the name
 156   ;;   Check it first
 157   (or (and (string-match "^/" file)
 158            (get-file-buffer (file-truename file)))
 159       (get-file-buffer file)))
 160
 161 (defun-maybe backward-line (&optional arg)
 162   (forward-line (if (integerp arg)
 163                     (- 0 arg)
 164                   -1)))
 165
 166 (defun-maybe abs (x)
 167   ;;  "Absolute value of X."
 168   (if (< x 0)
 169       (- x)
 170     x))
 171
 172 (defun-maybe int-to-float (nbr)
 173   "Convert integer NBR to float."
 174   (read (concat (int-to-string nbr) ".0")))
 175
 176 (defun-maybe logtest (x y)
 177   "Tinylibm: True if any bits set in X are also set in Y.
 178 Just like the Common Lisp function of the same name."
 179   (not (zerop (logand x y))))
 180
 181 (defun-maybe bin-string-to-int (8bit-string)
 182   "Convert 8BIT-STRING  string to integer."
 183   (let* ((list  '(128 64 32 16 8 4 2 1))
 184          (i   0)
 185          (int 0))
 186     (while (< i 8)
 187       (if (not (string= "0" (substring 8bit-string i (1+ i))))
 188           (setq int (+ int (nth i list) )))
 189       (incf  i))
 190     int))
 191
 192 (defun-maybe int-to-bin-string (n &optional length)
 193   "Convert integer N to bit string (LENGTH, default 8)."
 194   (let* ((i    0)
 195          (len  (or length 8))
 196          (s    (make-string len ?0)))
 197     (while (< i len)
 198       (if (not (zerop (logand n (ash 1 i))))
 199           (aset s (- len (1+ i)) ?1))
 200       (setq i (1+ i)))
 201     s))
 202
 203 (defun-maybe int-to-hex-string (n &optional separator pad)
 204   "Convert integer N to hex string. SEPARATOR between hunks is \"\".
 205 PAD says to padd hex string with leading zeroes."
 206   (or separator
 207       (setq separator ""))
 208   (mapconcat
 209    (function (lambda (x)
 210                (setq x (format "%X" (logand x 255)))
 211                (if (= 1 (length x))
 212                    (concat "0" x) x)))
 213    (list (ash n -24)
 214          (ash n -16)
 215          (ash n -8)
 216          n)
 217    separator))
 218
 219 (defun-maybe int-to-oct-string (n &optional separator)
 220   "Convert integer N into Octal. SEPARATOR between hunks is \"\"."
 221   (or separator
 222       (setq separator ""))
 223   (mapconcat
 224    (function (lambda (x)
 225                (setq x (format "%o" (logand x 511)))
 226                (if (= 1 (length x)) (concat "00" x)
 227                  (if (= 2 (length x)) (concat "0" x) x))))
 228    (list (ash n -27) (ash n -18) (ash n -9) n)
 229    separator))
 230
 231 (defun radix (str base)
 232   "Convert STR according to BASE."
 233   (let ((chars "0123456789abcdefghijklmnopqrstuvwxyz")
 234         (case-fold-search t)
 235         (n 0)
 236         i)
 237     (mapcar '(lambda (c)
 238                (setq i (string-match (make-string 1 c) chars))
 239                (if (>= (or i 65536) base)
 240                    (error "%c illegal in base %d" c base))
 241                (setq n (+ (* n base) i)))
 242             (append str nil))
 243     n))
 244
 245 (defun-maybe bin-to-int (str)
 246   "Convert STR into binary."
 247   (radix str 2))
 248
 249 (defun-maybe oct-to-int (str)
 250   "Convert STR into octal."
 251   (radix str 8))
 252
 253 (defun hex-to-int (str)
 254   "Convert STR into hex."
 255   (if (string-match "\\`0x" str)
 256       (setq str (substring str 2)))
 257   (radix str 16))
 258
 259 (defun-maybe int-to-net (float)
 260   "Decode packed FLOAT 32 bit IP addresses."
 261   (format "%d.%d.%d.%d"
 262           (truncate (% float 256))
 263           (truncate (% (/ float 256.0) 256))
 264           (truncate (% (/ float (* 256.0 256.0)) 256))
 265           (truncate (% (/ float (* 256.0 256.0 256.0)) 256))))
 266
 267 (defun-maybe rmac (string)
 268   "Decode STRING x-mac-creator and x-mac-type numbers."
 269   (if (numberp string)
 270       (setq string (format "%X" string)))
 271   (let ((i 0)
 272         (r ""))
 273     (while (< i (length string))
 274       (setq r (concat
 275                r
 276                (make-string
 277                 1
 278                 ;;  EWas call to 'rhex'
 279                 (hex-to-int (concat (make-string 1 (aref string i))
 280                                     (make-string 1 (aref string (1+ i)))))))
 281             i (+ i 2)))
 282     r))
 283
 284 (defun-maybe ctime (time)
 285   "Print a time_t TIME."
 286   (if (and (stringp time) (string-match "\\`[0-9]+\\'" time))
 287       (setq time (string-to-number (concat time ".0"))))
 288   (let* ((top (floor (/ time (ash 1 16))))
 289          ;; (bot (floor (mod time (1- (ash 1 16)))))
 290          (bot (floor (- time (* (ash 1 16) (float top))))))
 291     (current-time-string (cons top bot))))
 292
 293 (defsubst rand0 (n)
 294   "Random number in [0 .. N]."
 295   (cond
 296    ((<= n 0)
 297     0)
 298    (t
 299     (abs (% (random) n)))))
 300
 301 (defsubst-maybe rand1 (n)
 302   "Random number [1 .. N]."
 303   (1+ (rand0 n)))
 304
 305 (defun-maybe randij (i j)
 306   "Random number [I .. J]."
 307   (cond
 308    ((< i j) (+ i (rand0 (1+ (- j i)))))
 309    ((= i j) i)
 310    ((> i j) (+ j (rand0 (1+ (- i j)))))
 311    (t       (error "randij wierdness %s %s"
 312                    (ti::string-value i)
 313                    (ti::string-value j)))))
 314
 315 ;;; ... ... ... ... ... ... ... ... ... ... ... ... ... ... ...  split  ..
 316
 317 (unless (fboundp 'split-sting)
 318   (eval-and-compile
 319     (defun ti::split-string (string &optional regexp level cont-level)
 320       "Do not use this function. Call `split-string' instead.
 321 This function exists, because current Emacs did not define `split-string' and
 322 there is now alias which emulates the new Emacs behavior.
 323
 324 If called with only STRING, then split on white space.
 325
 326 Input:
 327
 328   STRING
 329   REGEXP        The delimiter in string, Default is '[\\f\\t\\n\\r\\v]+'
 330   LEVEL         The sub match in REGEXP to end reading substring.
 331                 Default is 0
 332   CONT-LEVEL    The sub match end to continue reading the STRING.
 333                 Default is 0 (REGEXP match's end point)
 334
 335 Example:
 336
 337   (split-string \"-I/dir1 -I/dir2\" \" *-I\")
 338   --> '(\"/dir1\" \"/dir2\")"
 339       (let ((start 0)
 340             str
 341             ret)
 342         (or regexp
 343             (setq regexp "[ \f\t\n\r\v]+"))
 344         (or level
 345             (setq level 0))
 346         (or cont-level
 347             (setq cont-level 0))
 348
 349         ;;  If no match, return as is '(string)
 350
 351         (if (null (string-match regexp string ))
 352             (setq ret (list string))
 353           (while (string-match regexp string start)
 354             (setq str (substring string start (match-beginning level)))
 355             (setq start (match-end cont-level))
 356             ;; Ignore BOL matches. There is no string for us.
 357             (if (> (match-beginning level) 0)
 358                 (push str ret)))
 359           ;;  Try with " test" --> '("test")
 360           (if (and (> start 0)
 361                    (< start (length string)))
 362               (push (substring string start) ret)))
 363         (nreverse ret)))))
 364
 365 (defun-maybe split-string (string &optional separators)
 366   ;; (split-string STRING &optional SEPARATORS)
 367   ;; in XEmacs 19.14 subr.el
 368   ;;  "Split string on whitespace."
 369   (ti::split-string string separators))
 370
 371 ;;; .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. higher Emacs . .
 372 ;;:  Features found from new emacs only 20.xx
 373
 374 ;; In simple.el, old Emacs does not have this.
 375 (and (fboundp 'delete-indentation)
 376      (defalias-maybe 'join-lines 'delete-indentation))
 377
 378 (defun-maybe replace-char-in-string (ch1 ch2 string)
 379   ;;  "Search CH1, change it with CH2 in STRING."
 380   (nsubstitute ch1 ch2 string))
 381
 382 (defun-maybe string-prefix-p (s1 s2)
 383   ;;  "True if string S1 is a prefix of S2 (i.e. S2 starts with S1)"
 384   (equal 0 (string-match (regexp-quote s1) s2)))
 385
 386 (put 'with-temp-buffer 'lisp-indent-function 0)
 387 (put 'with-temp-buffer 'edebug-form-spec '(body))
 388 (defmacro-maybe with-temp-buffer (&rest forms)
 389   "Create a temporary buffer, and evaluate FORMS there like `progn'."
 390   (let ((temp-buffer (make-symbol "temp-buffer")))
 391     (`
 392      (let (((, temp-buffer)
 393             (get-buffer-create (generate-new-buffer-name " *temp*"))))
 394        (unwind-protect
 395            (save-excursion
 396              (set-buffer (, temp-buffer))
 397              (,@ forms))
 398          (and (buffer-name (, temp-buffer))
 399               (kill-buffer (, temp-buffer))) )))))
 400
 401 (defun-maybe byte-compiling-files-p ()
 402   "Return t if currently byte-compiling files."
 403   (string= (buffer-name) " *Compiler Input*"))
 404
 405 ;; #todo: This already exists in some XEmacs
 406
 407 (put 'with-output-to-string 'edebug-form-spec '(body))
 408 (defmacro-maybe with-output-to-string (&rest body) ;XEmacs has this
 409   "Please use `shell-command-to-string'. Execute BODY and return string."
 410   (`
 411    (save-current-buffer
 412      (set-buffer (get-buffer-create " *string-output*"))
 413      (setq buffer-read-only nil)
 414      (buffer-disable-undo (current-buffer))
 415      (erase-buffer)
 416      (let ((standard-output (current-buffer)))
 417        (,@ body))
 418      (buffer-string))))
 419
 420 ;;; ----------------------------------------------------------------------
 421 ;;;
 422 (unless (fboundp 'with-buffer-unmodified)
 423   ;;  Appeared in Emacs 21.2
 424   (put 'with-buffer-modified 'lisp-indent-function 0)
 425   (put 'with-buffer-modified 'edebug-form-spec '(body))
 426   (defmacro with-buffer-modified (&rest body)
 427     "This FORM saves modified state during execution of body.
 428 Suppose buffer is _not_ modified when you do something in the BODY,
 429 e.g. set face properties: changing face also signifies
 430 to Emacs that buffer has been modified. But the result is that when
 431 BODY finishes; the original buffer modified state is restored.
 432
 433 This form will also make the buffer writable for the execution of body,
 434 but at the end of form it will restore the possible read-only state as
 435 seen my `buffer-read-only'
 436
 437 \(with-buffer-modified
 438    (set-text-properties 1 10 '(face highlight)))
 439
 440 "
 441     (` (let* ((Buffer-Modified (buffer-modified-p))
 442               (Buffer-Read-Only buffer-read-only))
 443          (prog1
 444              (progn
 445                (setq buffer-read-only nil)
 446                (,@ body)))
 447          (if Buffer-Modified
 448              (set-buffer-modified-p t)
 449            (set-buffer-modified-p nil))
 450          (if Buffer-Read-Only
 451              (setq buffer-read-only t)
 452            (setq buffer-read-only nil))))))
 453
 454 ;; `save-excursion' is expensive; use `save-current-buffer' instead
 455 (put 'save-current-buffer 'edebug-form-spec '(body))
 456 (defmacro-maybe save-current-buffer (&rest body)
 457   "Save the current buffer; execute BODY; restore the current buffer.
 458     Executes BODY just like `progn'."
 459   (` (save-excursion (,@ body))))
 460
 461 (put 'with-current-buffer 'lisp-indent-function 1)
 462 (put 'with-current-buffer 'edebug-form-spec '(body))
 463 (defmacro-maybe with-current-buffer (buffer &rest body)
 464   "tinylibm.el
 465 Execute the forms in BODY with BUFFER as the current buffer.
 466     The value returned is the value of the last form in BODY.
 467     See also `with-current-buffer'."
 468   (`
 469    (save-current-buffer
 470      (set-buffer (, buffer))
 471      (,@ body))))
 472
 473 (defmacro-maybe with-output-to-file (file &rest body)
 474   "Open FILE and run BODY.
 475 \(with-output-to-file \"foo\"
 476   (print '(bar baz)))."
 477   `(with-temp-file ,file
 478      (let ((standard-output (current-buffer)))
 479        ,@body)))
 480
 481 ;; Emacs 19.30 and below don't have this
 482
 483 (defun-maybe match-string (level &optional string)
 484   ;;  "Read match from buffer at sub match LEVEL. Optionally from STRING.
 485   ;;Return nil, if match at LEVEL doesn't exist.
 486   ;;
 487   ;;You have to call `looking-at' etc. before using this function.
 488   ;;You can use use `ti::buffer-match' or `ti::string-match' directly too."
 489   (if (match-end level)
 490       (if (stringp string)
 491           (substring
 492            string
 493            (match-beginning level) (match-end level))
 494         (buffer-substring
 495          (match-beginning level) (match-end level)))))
 496
 497 ;; (replace-regexp-in-string
 498 ;;   REGEXP REP STRING &optional FIXEDCASE LITERAL SUBEXP START)
 499
 500 ;;  (string regexp rep &optional subexp count)
 501 ;;
 502 (defun-maybe replace-regexp-in-string
 503   (regexp rep string &optional fixedcase literal subexp start)
 504   (let* ((i  0))
 505     (or subexp
 506         (setq subexp 0))
 507     (while (string-match regexp string)
 508       (if (> (incf i) 5000)
 509           (error "Substituted string causes circular match. Loop never ends.")
 510         (inline (setq string (ti::replace-match subexp rep string)))))
 511     string))
 512
 513 (defun-maybe buffer-substring-no-properties (beg end)
 514   (ti::remove-properties (buffer-substring beg end)))
 515
 516 ;; Here's the pre-Emacs 20.3 definition.  Note the optional arg.
 517
 518 (defun-maybe match-string-no-properties (num &optional string)
 519   ;;   "Return string of text matched by last search, without text properties.
 520   ;; NUM specifies which parenthesized expression in the last regexp.
 521   ;;  Value is nil if NUMth pair didn't match, or there were less than NUM pairs.
 522   ;; Zero means the entire text matched by the whole regexp or whole string.
 523   ;; STRING should be given if the last search was by `string-match' on STRING."
 524   (if (match-beginning num)
 525       (if string
 526           (let ((result
 527                  (substring string (match-beginning num) (match-end num))))
 528             (set-text-properties 0 (length result) nil result)
 529             result)
 530         (buffer-substring-no-properties (match-beginning num)
 531                                         (match-end num)))))
 532
 533 ;; This is from pcvs.el
 534 (defun-maybe file-to-string (file &optional oneline args)
 535   "Read the content of FILE and return it as a string.
 536 If ONELINE is t, only the first line (no \\n) will be returned.
 537 If ARGS is non-nil, the file will be executed with ARGS as its
 538 arguments.  If ARGS is not a list, no argument will be passed."
 539   (with-temp-buffer
 540     (condition-case nil
 541         (progn
 542           (if args
 543               (apply 'call-process
 544                      file nil t nil (when (listp args) args))
 545             (insert-file-contents file))
 546           (buffer-substring (point-min)
 547                             (if oneline
 548                                 (progn (goto-char (point-min))
 549                                        (end-of-line)
 550                                        (point))
 551                               (point-max))))
 552       (file-error nil))))
 553
 554 (defun-maybe file-name-extension (filename)
 555   (ti::file-get-extension filename))
 556
 557 (defun-maybe file-name-sans-extension (filename)
 558   ;;  "Return FILENAME without extension."
 559   (replace-regexp-in-string "\\.[^.]+$" ""  filename))
 560
 561 ;; Emacs 20.3 invented its own function names `line-beginning-position'
 562 ;; `line-end-position' while XEmacs already had had point-* function
 563 ;; names since 1996: `point-at-eol' and `point-at-bol'.
 564
 565 (defsubst-maybe line-beginning-position (&optional n)
 566   "Return begin position of line forward N."
 567   (save-excursion
 568     (if n
 569         (forward-line n))
 570     (beginning-of-line) (point)))
 571
 572 (defsubst-maybe line-end-position (&optional n)
 573   "Return end position of line forward N."
 574   (save-excursion
 575     (if n
 576         (forward-line n))
 577     (end-of-line) (point)))
 578
 579 (defsubst-maybe insert-file-literally (file) ;; XEmacs 21.4 does not have this
 580   "Insert contents of file FILENAME into buffer after point with no conversion."
 581   (let (find-file-hooks
 582         write-file-hooks
 583         auto-save-hook
 584         auto-save-default)
 585     (insert-file file)))
 586
 587 (eval-and-compile
 588   (if (locate-library "executable") ;; 20.4 defines this
 589       (autoload 'executable-find "executable")
 590     (defun-maybe executable-find (program-name)
 591       ;;  "Find PROGRAM-NAME along `exec-path'."
 592       (ti::file-get-load-path program-name exec-path))))
 593
 594 (defun-maybe executable-find-in-system (program-name) ;Handle Win32 case too.
 595   ;;   "Find PROGRAM-NAME along `exec-path'.
 596   ;; The PROGRAM-NAME should not contain system dependent prefixes; an
 597   ;; .exe is added automatically on PC."
 598   (if (ti::win32-p)
 599       (or (executable-find (concat program-name ".exe"))
 600           (executable-find (concat program-name ".com"))
 601           (executable-find (concat program-name ".bat"))
 602           (executable-find (concat program-name ".cmd")))
 603     (executable-find program-name)))
 604
 605 ;;; .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. XEmacs20 char . .
 606
 607 (defmacro ti::compat-character-define-macro (function1 function2)
 608   "Define XEmacs compatible character FUNCTION2 as an alias for FUNCTION1."
 609   (`
 610    (when (or (not (fboundp (, function1)))
 611              (and (ti::emacs-p)
 612                   (fboundp (, function1))
 613                   (or (not (equal (symbol-function (, function1))
 614                                   (, function2)))
 615                       ;;  If the definition is 'ignore, reassign correct
 616                       ;;  function.
 617                       (equal (symbol-function (, function1))
 618                              'ignore))))
 619      (defalias (, function1) (, function2)))))
 620
 621 (defun ti::compat-char-int-p (ch)     ;Not in Emacs (in XEmacs20 MULE)
 622   (and (integerp ch)
 623        (> ch -1)                        ;valid range 0-255
 624        (< ch 255)))
 625
 626 (defun ti::compat-define-compatibility-defalias ()
 627   "Emacs and XEmacs compatibility.
 628 Define XEmacs character functions to work in Emacs.
 629 Function mappings are:
 630
 631   int-to-char      identity
 632   char-equal       equal
 633   char-to-int      identity
 634   chars-in-string  length
 635   characterp       integerp
 636   char-int-p       ti::compat-char-int-p
 637   char-int         identity"
 638   ;;  - In Emacs the characters are treated as integers
 639   ;;  - In XEmacs charactersa are their own data type
 640   (dolist (elt '((int-to-char identity)
 641                  (char-equal  equal)
 642                  ;;  Not in Emacs (exist in XEmacs 20)
 643                  (char-to-int identity)
 644                  ;;  Emacs 20.2/20.3 change
 645                  (chars-in-string length)
 646                  ;;  exists only in XEmacs
 647                  (characterp integerp)
 648                  (char-int-p ti::compat-char-int-p)
 649                  (char-int   identity)))
 650     (multiple-value-bind (original alias) elt
 651       (ti::compat-character-define-macro original alias))))
 652
 653 (ti::compat-define-compatibility-defalias)
 654
 655 (defun-maybe char= (ch1 ch2 &optional ignored-arg) ;exists in  XEmacs 20.1
 656   (let* (case-fold-search)                         ;case sensitive
 657     (char-equal ch1 ch2)))
 658
 659 ;;  eshell-mode.el fix
 660 (eval-after-load "eshell-mode"
 661   '(progn (ti::compat-define-compatibility-defalias)))
 662
 663 ;;  eshell-2.4.1/esh-mode.el  mistakenly defines characterp
 664 ;;  as alias to `ignore' => breaks many things
 665 (eval-after-load "esh-mode"
 666   '(progn (ti::compat-define-compatibility-defalias)))
 667
 668 ;;  Gnus MIME handling also behaves wrong
 669 (eval-after-load "mm-decode"
 670   '(progn (ti::compat-define-compatibility-defalias)))
 671
 672 ;; See cplus-md.el
 673 (defun-maybe count-char-in-string (c s)
 674   "Count CHARACTER in STRING."
 675   (let ((count 0)
 676         (pos   0))
 677     (while (< pos (length s))
 678       (if (char= (aref s pos) c)
 679           (incf  count))
 680       (incf  pos))
 681     count))
 682
 683 (defun-maybe count-char-in-region  (beg end char)
 684   "In region BEG END, count all CHAR occurrences.
 685 E.g. to have real line count in buffer that
 686 is running folding.el or outline, you should not call
 687 count-lines function , but (count-char-in-region ?\\n)"
 688   (interactive "r\ncChar: ")
 689   (let* ((i 0))
 690     (setq end (max beg end)
 691           char (char-to-string char))
 692     (save-excursion
 693       (goto-char (min beg end))
 694       (while (search-forward char end  t)
 695         (incf  i)))
 696     (if (interactive-p)
 697         (message "%d hits in region." i))
 698     i))
 699
 700 (defun-maybe char-assq (ch alist)
 701   "If CH can be found in ALIST, return entry. If CH is nil, do nothing."
 702   (let (case-fold-search
 703         ret)
 704     (while (and ch alist)
 705       (setq ret (car alist))
 706       (if (char= ch (car ret))
 707           (setq alist nil)
 708         (setq alist (cdr alist)
 709               ret nil) ))
 710     ret))
 711
 712 ;;  XEmacs : replace-in-string
 713 ;;  Emacs 20.4
 714 (defun-maybe subst-char-in-string (fromchar tochar string &optional inplace)
 715   "Replace FROMCHAR with TOCHAR in STRING each time it occurs.
 716 INPLACE is ignored."
 717   (let ((len   (length string))
 718         (ret   (copy-sequence string))) ;because 'aset' is destructive
 719     (while (> len 0)
 720       (if (char= (aref string (1- len)) fromchar)
 721           (aset ret (1- len) tochar))
 722       (decf len))
 723     ret))
 724
 725 (defun-maybe subst-char-with-string (string &optional char to-string)
 726   "In STRING, convert CHAR with TO-STRING.
 727 Default is to convert all tabs in STRING with spaces."
 728   (let* ((len           (length string))
 729          (i             0)
 730          elt
 731          ret)
 732     (cond
 733      ((not (and char to-string))
 734       (with-temp-buffer
 735         (insert string)
 736         (untabify (point-min) (point-max))
 737         (setq ret (buffer-string))))
 738      (t
 739       (while (< i len)
 740         (setq elt (char-to-string (aref string i)))
 741         (if (char= char (aref string i))
 742             (setq elt to-string))
 743         (setq ret (concat ret elt))
 744         (incf  i))))
 745     ret))
 746
 747 (eval-and-compile
 748   (when (or (featurep 'xemacs)
 749             (boundp 'xemacs-logo))
 750     ;;   Just a forward declaration, because byte-compiler cannot see through
 751     ;;   defun-maybe. If this function already exists, this autoload
 752     ;;   definition is no-op.
 753     (autoload 'subst-char-in-string "tinylibb.el")))
 754
 755 ;; Emacs and XEmacs differ here. Convert Emacs function --> XEmacs name
 756
 757 (cond
 758  ((and (fboundp 'exec-to-string)
 759        (not (fboundp 'shell-command-to-string)))
 760   (defalias-maybe 'shell-command-to-string 'exec-to-string))
 761  ((not (fboundp 'shell-command-to-string))
 762   (defun-maybe shell-command-to-string (command)
 763     "Returns shell COMMAND's ouput as string. Tinylibm."
 764     (with-temp-buffer
 765       (shell-command command (current-buffer))
 766       (buffer-string)))))
 767
 768 ;;; XEmacs ilisp.el :: describe-symbol-find-file
 769 (defun-maybe describe-symbol-find-file (symbol) ;; XEmacs
 770   "Find SYMBOL defined in file."
 771   (loop for (file . load-data) in load-history
 772         do (when (memq symbol load-data)
 773              (return file))))
 774
 775 ;; shell.el, term.el, terminal.el
 776
 777 (unless (boundp 'explicit-shell-file-name)
 778   (defvar explicit-shell-file-name nil))
 779
 780 (unless (boundp 'shell-command-output-buffer)
 781   (defvar shell-command-output-buffer "*Shell Command Output*"))
 782
 783 (when (or (not (boundp 'temporary-file-directory))
 784           (not (stringp temporary-file-directory))
 785           (not (file-directory-p temporary-file-directory)))
 786   (let* ((temp (or (getenv "TEMP")
 787                    (getenv "TEMPDIR")
 788                    (getenv "TMPDIR"))))
 789     (defvar temporary-file-directory    ;Emacs 20.3
 790       (or temp
 791           (cond
 792            ((file-directory-p "/tmp") "/tmp")
 793            ((file-directory-p "~/tmp") "~/tmp")
 794            ((file-directory-p "C:/temp") "C:/temp")
 795            ;; don't know what to do, maybe this exists.
 796            (t "/")))
 797       "*Tinylib: XEmacs and Emacs compatibility.")))
 798
 799 ;;; ........................................................... &other ...
 800
 801 ;; Emacs 20.7 - 21.2 does not have this
 802 (defun-maybe turn-off-font-lock ()
 803   "Turn off font lock."
 804   (font-lock-mode -1))
 805
 806 ;; Emacs 21.3 includes `turn-on-font-lock'
 807 (defun-maybe turn-on-font-lock-mode ()
 808   "Turn on font lock."
 809   (font-lock-mode 1))
 810
 811 (defun-maybe turn-on-auto-fill-mode ()
 812   "Turn on Auto Fill mode."
 813   (auto-fill-mode 1))
 814
 815 (defun font-lock-mode-maybe (&optional mode check-global)
 816   "Pass MODE to function `font-lock-mode' only on color display.
 817 If CHECK-GLOBAL is non-nil, the `global-font-lock-mode' flag must also
 818 be non-nil before calling.
 819
 820 Usually there is no point of turning on `font-lock-mode' if Emacs
 821 can't display colors, so this is is the umbrella function to
 822 font-lock.el"
 823   (when (and (featurep 'font-lock)
 824              (ti::colors-supported-p)
 825              (or (null check-global)
 826                  (and (boundp 'global-font-lock-mode)
 827                       (symbol-value 'global-font-lock-mode))))
 828     (font-lock-mode mode)
 829     t))
 830
 831 (defun turn-on-font-lock-mode-maybe ()
 832   "Call `font-lock-mode-maybe' with argument 1."
 833   (font-lock-mode-maybe 1))
 834
 835 (defalias-maybe 'compose-mail 'mail)
 836
 837 (defun-maybe region-active-p ()         ;XEmacs function
 838   "Return `mark' if mark (region) is active."
 839   (cond
 840    ((and (ti::xemacs-p)
 841          (boundp 'zmacs-regions))
 842     (let* ((zmacs-regions t))           ;XEmacs
 843       (mark)))
 844    ((boundp 'mark-active)               ;Emacs
 845     (and (symbol-value 'mark-active)
 846          ;;  used to return (mark-marker)
 847          (mark 'noerr)))))
 848
 849 ;; Newer advice "2.15" uses this call, make sure it exist.
 850 (defalias-maybe 'byte-code-function-p 'ignore)
 851
 852 (defun-maybe add-to-list (list-var element)
 853   ;;  "Add to symbol LIST-VAR ELEMENT."
 854   (or (member element (symbol-value list-var)) ;; copy from 19.34
 855       (set list-var (cons element (symbol-value list-var)))))
 856
 857 (defun-maybe run-hook-with-args-until-success
 858   (hook-sym &optional &rest args)
 859   ;;   "Run all functions in HOOK-SYM. Stop when first one return non-nil.
 860   ;;
 861   ;; Input:
 862   ;;
 863   ;;   HOOK-SYM  hook symbol, or list of functions.
 864   ;;   ARGS           arguments to functions. if NIL, functions
 865   ;;             are called without arguments."
 866   (let* ((val  (symbol-value hook-sym))
 867          (list (if (listp val) val (list val))) ;Make list maybe
 868          ret
 869          func)
 870     (while (and (null ret) list)
 871       (setq func (car list)   list (cdr list))
 872       (setq ret (apply func args)))
 873     ret))
 874
 875 (defun-maybe buffer-live-p (buffer)
 876   ;;  "Check if BUFFER exist."
 877   (cond
 878    ((not (bufferp buffer))
 879     (error "must be pointer"))
 880    ((stringp buffer)
 881     (get-buffer buffer))
 882    (buffer
 883     (buffer-name buffer))))
 884
 885 (eval-when-compile
 886   ;;  don't show "obsolete function warning", because we know what
 887   ;;  we're doing below.
 888   (put 'frame-parameters 'byte-compile nil))
 889
 890 (when (not (fboundp 'frame-parameter))  ;Emacs 19.35
 891   (if (fboundp 'frame-property)
 892       (defalias 'frame-parameter 'frame-property) ; XEmacs.
 893     (defun frame-parameter (frame property &optional default)
 894       "Return FRAME's value for property PROPERTY."
 895       (or (cdr (assq property (frame-parameters frame)))
 896           default))))
 897
 898 (unless (and (fboundp 'find-file-binary) ;; Emacs function --> XEmacs
 899              (boundp 'buffer-file-coding-system))
 900   (defun find-file-binary (file)
 901     "Read FILE without conversiosn."
 902     (let* ((buffer-file-coding-system 'binary))
 903       (unless buffer-file-coding-system
 904         (setq buffer-file-coding-system nil)) ;Quiet Bytecompiler "unused  var".
 905       (find-file file))))
 906
 907 ;;}}}
 908 ;;{{{ special
 909
 910 ;;; ........................................... &compatibility-special ...
 911 ;;; These need emacs-p xemacs-p tests
 912
 913 ;; not known function in 19.14
 914
 915 (eval-and-compile
 916   (autoload 'read-kbd-macro "edmacro")
 917   (when (ti::emacs-p)
 918     (or (fboundp 'kbd)                  ;Std in Emacs 20.x
 919         (defmacro kbd (keys)            ;(kbd "C-<delete>")
 920           "Convert KEYS to the internal Emacs key representation.
 921 KEYS should be a string constant in the format used for
 922 saving keyboard macros (see `insert-kbd-macro')."
 923           (let ((f 'read-kbd-macro))
 924             (funcall f keys))))))
 925
 926 ;;}}}
 927 ;;{{{ code: function test
 928
 929 ;;; ...................................................... &func-tests ...
 930 ;;; We define these here because they are used lated in this library
 931 ;;; "define before using"
 932
 933 (eval-and-compile
 934
 935 ;;; ----------------------------------------------------------------------
 936 ;;;
 937   (defun-maybe functionp (obj) ;; Emacs 20.3+ XEmacs 20.x
 938     (or (subrp obj)
 939         (byte-code-function-p obj)
 940         (and (symbolp obj)
 941              (fboundp obj))
 942         (and (consp obj)
 943              (eq (car obj) 'lambda))))
 944
 945 ;;; ----------------------------------------------------------------------
 946 ;;;
 947   (defun ti::function-args-p (symbol)
 948     "Return function SYMBOL's argument list as string or nil.
 949 Works for byte compiled functions too.
 950
 951 Notes:
 952   if function is alias, the real function behind it is examined.
 953   if function is in autoload state, \"(autoload-args)\" is returned."
 954     (let* ((args-re-xemacs ;; arguments: (&optional BUFFER)
 955             "arguments: +(\\([^)]+\\))")
 956            (args-re ;; (buffer-size &optional BUFFER)
 957             "([^(]+\\([^)]+)\\)")
 958            sym
 959            sym-func
 960            str
 961            ret)
 962       (if (ti::autoload-p symbol)
 963           ;;  We can't know the args. And we don't want to find out,
 964           ;;  since it would load the package unnecessarily
 965           (setq ret "(autoload-args)")
 966         (if (setq sym (ti::defalias-p symbol))
 967             (setq symbol sym))
 968         (setq sym-func (symbol-function symbol))
 969         (if (subrp sym-func)
 970             (setq str (documentation sym-func))
 971           (setq str (prin1-to-string sym-func)))
 972         ;;  "$ad-doc: mouse-yank-at-click$" (interactive "e\nP")
 973         (when (and (string-match "ad-doc:" str)
 974                    (setq symbol
 975                          (intern-soft
 976                           (format "ad-Orig-%s"
 977                                   (symbol-name symbol)))))
 978           (setq str (prin1-to-string  (symbol-function symbol))))
 979         (cond
 980          ((ti::emacs-p)
 981           (cond
 982            ;; "#[(click arg)
 983            ((string-match "^#\\[(\\([^)]+\\)" str)
 984             (setq ret (match-string 1 str)))
 985            ((or (string-match "^(lambda[ \t]+nil" str)
 986                 (string-match "^#\\[nil" str))
 987             (setq ret nil))
 988            ((string-match args-re str)
 989             (setq ret (match-string 1 str))
 990             ;;  Empty arg list
 991             (if (string= ret "")
 992                 (setq ret nil)))))
 993          (t
 994           ;;  XEmacs has different Byte compilation format
 995           ;;  #<compiled-function (from "custom.elc") nil "...(7)
 996           (cond
 997            ((string-match
 998              (concat "compiled-function +\(from.*\) +" args-re) str)
 999             (setq ret (match-string 2)))
1000            ((string-match "^(lambda +nil" str)) ;bypass
1001            ((string-match args-re-xemacs str)
1002             (setq ret (match-string 1 str)))
1003            ((string-match args-re str)
1004             (setq ret (match-string 1 str)))))))
1005       ret)))
1006
1007 ;;; --++-- --++-- --++-- --++-- --++-- --++-- --++--  eval-and-compile --
1008
1009 ;;}}}
1010 ;;{{{ code: Cygwin support
1011
1012 ;;; ........................................................... cygwin ...
1013
1014 ;;; Patch for these functions has been submitted to Emacs 21.2
1015 ;;; (w32-fns.el)
1016
1017 (defvar w32-cygwin-mount-table nil
1018   "Cygwin mount.exe mapping. See `w32-cygwin-mount-table'.")
1019
1020 ;;; ----------------------------------------------------------------------
1021 ;;;
1022 (put 'w32-cygwin-mount-table-dolist 'lisp-indent-function 0)
1023 (put 'w32-cygwin-mount-table-dolist 'edebug-form-spec '(body)) ;;#todo: not working
1024 (defmacro w32-cygwin-mount-table-dolist (&rest body)
1025   "Run DOLIST for Cygwin mount table.
1026 `mount' is complete mount element (cygwin . dos).
1027 Variables `cygwin' and `dos' are bound respectively."
1028   (`
1029    (dolist (mount w32-cygwin-mount-table)
1030      ;;  mount => ("/tmp" . "c:\\temp")
1031      (let* ((cygwin (car mount))
1032             (dos    (cdr mount)))
1033        (,@ body)))))
1034
1035 ;;; ----------------------------------------------------------------------
1036 ;;;
1037 (put 'w32-cygwin-shell-environment 'lisp-indent-function 0)
1038 (put 'w32-cygwin-shell-environment 'edebug-form-spec '(body))
1039 (defmacro w32-cygwin-shell-environment  (&rest body)
1040   "Run BODY under Cygwin shell environment.
1041 For example, you you want to call program ´zgrep' which is not an
1042 .exe, but a shell program, you have to switch to the Cygwin context.
1043
1044    (when (and (ti::win32-p)
1045               (ti::win32-cygwin-p))
1046       (w32-cygwin-shell-environment
1047            ...))
1048
1049 Variable ´shell-file-name' is locally bound during call."
1050   (`
1051    (let ((shell-file-name (format "%s/bin/hash.exe"
1052                                   (ti::win32-cygwin-p 'use-cache))))
1053      (,@ body))))
1054
1055 ;;; ----------------------------------------------------------------------
1056 ;;;
1057 (defun w32-cygwin-mount-table-parse ()
1058   ;; "Parse cygwin mount table from current point forward."
1059
1060   ;;  Search lines with backslash
1061   ;;  f:\\u\\bin /usr/bin user binmode
1062   ;;
1063   ;;  Cygwin 1.3.3 changed format, it is now
1064   ;;
1065   ;;  f:\\u\\bin on /usr/bin type user (binmode)
1066   ;;             ==
1067   ;;
1068   ;;  \\network\path\this
1069
1070   (let (list
1071         (regexp
1072          (save-excursion
1073            (if (re-search-forward "^\\([a-z]:\\|[\\][\\]\\).* on " nil t)
1074                (concat
1075                 "^\\([a-zA-Z]:[\\][^ \t\r\n]*"
1076                 "\\|[a-zA-Z]:"
1077                 "\\|[\\][\\][^ \t\r\n]+"
1078                 "\\)"
1079                 "[ \t]+on[ \t]+"
1080                 "\\(/[^ \t\r\n]*\\)")
1081              (concat
1082               "^\\([a-zA-Z]:[\\][^ \t\r\n]*"
1083               "\\|[a-zA-Z]:"
1084               "\\|[\\][\\][^ \t\r\n]+"
1085               "\\)"
1086               "[ \t]+"
1087               "\\(/[^ \t\r\n]*\\)")))))
1088     (while (re-search-forward regexp nil t)
1089       (let ((dos    (match-string 2))
1090             (cygwin (match-string 1)))
1091         (push (cons dos cygwin)
1092               list)))
1093
1094     ;;  sort the entries so that the longest mounts come first and
1095     ;;  last the shortest. This makes a difference when Cygwin paths are
1096     ;;  converted back to dos:
1097     ;;
1098     ;;    /tmp/other       mapping must be handled before /tmp
1099     ;;    /tmp
1100     ;;    ..
1101
1102     (sort list
1103           (function
1104            (lambda (a b)
1105              (> (length (car a))
1106                 (length (car b))))))))
1107
1108 ;;; ----------------------------------------------------------------------
1109 ;;;
1110 (defun w32-cygwin-convert (path &optional flag)
1111   "Run `cygpath' to find out PATH.
1112 Return:
1113
1114    The default concersion is CYGWIN => DOS
1115
1116    If `flag' is set, then the conversion is
1117    DOS => cygwin."
1118   (let* ((cmd     (executable-find "cygpath"))
1119          (option  "--windows")
1120          ret)
1121     (when cmd
1122       (when flag
1123         (setq option "--unix"))
1124       (with-temp-buffer
1125         (call-process
1126          cmd
1127          nil
1128          (current-buffer)
1129          nil
1130          option
1131          path)
1132         (goto-char (point-min))
1133         (when (looking-at "^.*") ;; Filter newlines
1134           (setq ret (match-string 0)))))
1135     ret))
1136
1137 ;;; ----------------------------------------------------------------------
1138 ;;;
1139 (defun w32-cygwin-mount-table ()
1140   ;; "Return Cygwin mount table '((CYGWIN . DOS) ..) using `mount' command."
1141   (when ;; (memq system-type '(ms-dos windows-nt))
1142       (ti::win32-p)
1143     ;; specifically request the .exe which must be along PATH
1144     ;; if we used only `mount', that could call user's "mount.bat" or
1145     ;; something.
1146     (let ((cmd  (executable-find "mount.exe")))
1147       (when cmd
1148         (with-temp-buffer
1149           (call-process cmd nil (current-buffer))
1150           (goto-char (point-min))
1151
1152           ;;  It's a serious error if "mount" does not say where
1153           ;;  the ROOT "/" is. Should we do something?
1154
1155           (goto-char (point-min))
1156           (let ((ret (w32-cygwin-mount-table-parse)))
1157             (unless ret
1158               (error "Cygwin mount.exe output parse failed:\n[%s]"
1159                      (buffer-string)))
1160             ret))))))
1161
1162 ;;; ----------------------------------------------------------------------
1163 ;;;
1164 (defun w32-cygwin-mount-point-to-dos (path)
1165   "Convert Cygwin mount filenames like  /tmp to DOS paths."
1166   (let* (last-choice
1167          try)
1168     (dolist (cygwin w32-cygwin-mount-table)
1169       (when (string-match (concat "^"  (car cygwin) "\\(.*\\)")
1170                           path)
1171         (setq try
1172               ;;  expand will ensure that slashes are after glue
1173               ;;  to the same direction
1174               (expand-file-name
1175                (concat (file-name-as-directory (cdr cygwin) )
1176                        (match-string 1 path))))
1177         ;;  It is difficult to expand the file name correctly because
1178         ;;  user can make any mount points. That's what we compare which
1179         ;;  mount point gives the longest match and return it.
1180         ;;
1181         ;;  E.g. the root / will always match, but it is not necessarily
1182         ;;  the final answer given path /tmp/something where there is
1183         ;;  separate mount point for longer match /tmp
1184         ;;
1185         (if (null last-choice)
1186             (setq last-choice (cons (car cygwin) try))
1187           (if (length (> (car cygwin) (car last-choice)))
1188               (setq last-choice (cons (car cygwin) try))))))
1189     (if (null last-choice)
1190         path
1191       (cdr last-choice))))
1192
1193 ;;; ----------------------------------------------------------------------
1194 ;;;
1195 (defun w32-cygwin-mount-table-set ()
1196   ;;   "Run mount.exe and set internal variable `w32-cygwin-mount-table'.
1197   ;; You should run this function after you have made a change to
1198   ;; cygwin mount points."
1199   ;;   (interactive)
1200   (if (ti::win32-p) ;; (memq system-type '(ms-dos windows-nt))
1201       (setq w32-cygwin-mount-table
1202             (w32-cygwin-mount-table))))
1203
1204 ;;; ----------------------------------------------------------------------
1205 ;;;
1206 (defun w32-cygwin-mount-table-path-to-dos (path)
1207   "Convert PATH to dos using cygwin mount table.
1208 You should not call this function, use `w32-cygwin-path-to-dos'."
1209   ;;  Convert Cygwin /usr/local to DOS path. LOCATION/usr/local.
1210   ;;  This relies on the fact that the longest paths are first
1211   ;;  in the mount table.
1212   (let (final-path)
1213     (w32-cygwin-mount-table-dolist
1214       ;;  mount => ("/tmp" . "c:\\temp")
1215       ;;  variables `cygwin' and `dos' are part of the macro
1216       (when (string-match (concat "^" (regexp-quote cygwin)
1217                                   "\\(.*\\)")
1218                           path)
1219         (unless (string= cygwin "/")
1220           (setq dos (concat dos (match-string 1 path))))
1221         ;; Convert to forward slashes
1222         (setq final-path (subst-char-in-string ?\\ ?/ dos))
1223         (return)))
1224     (unless final-path
1225       ;; None matched, so this path is under cygwin root dir.
1226       (let ((root (ti::win32-cygwin-p)))
1227         (setq final-path (concat root path))))
1228     final-path))
1229
1230 ;;; ----------------------------------------------------------------------
1231 ;;;
1232 (defun w32-cygwin-path-to-dos (path)
1233   "Convert cygwin like //c/temp  or /cygdrive/c/temp path to
1234   dos notation c:/temp."
1235   ;; NOTE for cygwin and bash shell prompt
1236   ;; We can't require a slash after the drive letter, because
1237   ;; //c   and  /cygdrive/c   are all top level roots.
1238   ;;
1239   ;; The bash shell's PS1 setting \w (The current working directory)
1240   ;; Does not add trailing slash.
1241   (cond
1242    ((or (string-match "^//\\([a-z]\\)/?$" path)
1243         (string-match "^/cygdrive/\\([a-z]\\)/?$" path))
1244     (concat (match-string 1 path) ":/"))
1245    ((or (string-match "^//\\([a-z]\\)\\(/.*\\)" path)
1246         (string-match "^/cygdrive/\\([a-z]\\)\\(/.*\\)" path))
1247     (concat (match-string 1 path) ":" (match-string 2 path)))
1248    ((string-match "^(/cygdrive/./\\|//" path)
1249     ;;  if previous regexps couldn't handle it, this is severe error.
1250     (error "Invalid path format for cygwin %s" path))
1251    ((string-match "[\\]" path)
1252     (error "Invalid backslash path %s" path))
1253    ((string-match "^/" path)
1254     (w32-cygwin-mount-table-path-to-dos path))
1255    (t
1256     path)))
1257
1258 ;;; ----------------------------------------------------------------------
1259 ;;;
1260 (defun w32-cygwin-dos-path-to-cygwin (path)
1261   "Convert dos PATH to cygwin path.
1262 Be sure to call `expand-file-name' before you pass PATH to the function."
1263   (cond
1264    ((string-match "\\([a-z]\\):[\\/]\\(.*\\)" path)
1265     (let ((drive     (format  "/cygdrive/%s/" (match-string 1 path)))
1266           (rest-path (match-string 2 path)))
1267       (if (not rest-path)
1268           drive
1269         (w32-cygwin-mount-table-dolist
1270           ;;  mount => ("/tmp" . "c:\\temp")
1271           ;;  variables `cygwin' and `dos' are part of the macro
1272           (when (or (string-match (concat "^" dos "\\(.*\\)") path)
1273                     (string-match (concat "^"
1274                                           ;; Convert to / slashes
1275                                           (expand-file-name dos)
1276                                           "\\(.*\\)") path))
1277             (when (match-string 1 path)
1278               (setq path (match-string 1 path))
1279               (setq cygwin (concat cygwin path)))
1280             ;; Convert to forward slashes
1281             (return (subst-char-in-string ?\\ ?/ cygwin)))))))
1282    (t
1283     (error "Cannot convert to cygwin. path is not absolute %s" path))))
1284
1285 ;;  Make it defconst, so that rereading tinylibb.el will always update
1286 ;;  the value. If Cygwin is changed, reloading this library.
1287
1288 (setq w32-cygwin-mount-table
1289       (if (ti::win32-p) ;; (memq system-type '(ms-dos windows-nt))
1290           (w32-cygwin-mount-table)))
1291
1292 (defsubst w32-expand-file-name-for-cygwin (path)
1293   "Expand PATH to Cygwin notation if Cygwin is present."
1294   (when (and (string-match "^[A-Za-z]:" path)
1295              (ti::win32-cygwin-p))
1296     (setq path (w32-cygwin-dos-path-to-cygwin path)))
1297   path)
1298
1299 (defsubst w32-expand-file-name-for-emacs (path)
1300   "Expand PATH to DOS Emacs notation if PATH is in Cygwin notation."
1301   (cond
1302    ((and (ti::emacs-type-win32-p)
1303          (string-match "^/cygdrive" path))
1304     (setq path (w32-cygwin-path-to-dos path)))
1305    ((and (ti::emacs-type-cygwin-p)
1306          (string-match "^[a-zA-Z]:" path))
1307     (setq path (w32-cygwin-dos-path-to-cygwin path))))
1308   path)
1309
1310 ;;}}}
1311
1312 ;;; ########################################################## &custom ###
1313
1314 ;;{{{ custom
1315
1316 ;;; 2000-03-20
1317 ;;; - This code is beginning to be obsolete now when Newest Emacs is 21.2
1318 ;;;   custom.el.
1319 ;;; - This code does nothing if custom.el is present, so let it be here.
1320
1321 (eval-and-compile
1322   (cond
1323    ((string-match "2[0-9]\\." (emacs-version))
1324     (require 'custom))                  ;Out of the box
1325    (t                           ;Well, this is old Emacs - lot of work
1326     (let* ((list  load-path)
1327            dir
1328            try
1329            path)
1330       (cond
1331        ;; ..................................................... no custom ...
1332        ;;  The reason why newest custom.el does not work in prior releases is the
1333        ;;  new bacquote macro syntax it uses. It needs new emacs lisp parser to
1334        ;;  read the macros.
1335        ;;
1336        ((or (and (ti::emacs-p)
1337                  (< emacs-minor-version  34))
1338             (and (eq 19 (ti::xemacs-p))
1339                  (< emacs-minor-version  15)))
1340         ;;  This emacs is too old for new custom. Emulate it.
1341         (defmacro defgroup (&rest args) nil)
1342         (defmacro defcustom (var value doc &rest args)
1343           (` (defvar (, var) (, value) (, doc)))))
1344        ;; .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. custom maybe . .
1345        (t
1346         ;; Explanation: When I say (require 'custom) in -batch byte
1347         ;; compile; and the load-path HAD my private ~/elisp at front,
1348         ;; but it still loaded old custom.elc from XEmacs 19.14 distribution.
1349         ;;
1350         ;; Why? Don't know. That's why we load it manually here.
1351         (while (and (null path)         ;Where it is?
1352                     (setq dir (car list)))
1353           (setq try
1354                 (if (string-match "/$" dir)
1355                     (concat dir "custom.el")
1356                   (concat dir "/custom.el")))
1357           (when (file-exists-p try)
1358 ;;;     (message (format "tinylibm: ** Using custom from [%s]" try))
1359             (setq path (file-name-directory try)))
1360           (setq list (cdr list)))
1361         ;; ............................................... load new custom ...
1362         (condition-case ()
1363             (progn
1364               ;; The new custom won't work in .el format, it must be
1365               ;; loaded in .elc format.
1366               (unless (featurep 'custom)
1367                 (load (concat path "custom.elc"))))
1368           (error
1369            (message "tinylibm: ** Couldn't find custom.elc [compiled version]")))
1370         ;;  Check few things, what this custom.elc provided.
1371         ;;  This is internal information to debug things
1372         ;;
1373         (message "tinylibm: ** internal info: Custom [%s] declare [%s]"
1374                  (if (featurep 'custom)
1375                      "t"
1376                    "nil")
1377                  (if (fboundp 'custom-declare-variable)
1378                      "t"
1379                    "nil"))
1380         (cond
1381          ((and (featurep 'custom)
1382                (fboundp 'custom-declare-variable))
1383           ;; .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. . case 1 ..
1384           ;;  19.14 includes a very old custom.el, and it shouldn't be used
1385           ;;  any more.
1386           ;;
1387           ;;  custom-XE19.14    : custom.el::customize()
1388           ;;  custom-1.96       : cus-edit.el::(defun customize (symbol)
1389           ;;  custom-1.9956     : cus-edit.el:::customize()
1390           ;;                      cus-edit.el::customize-group (group)
1391           (cond
1392            ((and (null (ti::function-args-p 'customize))
1393                  (not (fboundp 'customize-group)))
1394             (message "\
1395 tinylibm.el: ** [Ignore, Compilation is still going fine...]
1396              ** Hm, loading custom didn't go quite right. Reasons:
1397              ** a. You have too old custom.el library, because I can't
1398              **    see `customize' function to take ONE argument.
1399              **    Be sure to have newest custom.el and cus-edit.el
1400              ** b. Your load-path is set so that the old custom.el
1401              **    was loaded."))
1402            (t
1403             ;;  The new 1.9956 Custom.el produces warning for defcustom
1404             ;;  variables not beeing defined. This code is only for
1405             ;;  19.34 and won't work anywhere else.
1406             ;;
1407             (if (string-match
1408                  "19.2[0-9]\\|19.3[0-3]\\|19.1[0-4]"
1409                  (emacs-version))
1410                 (message "\
1411              ** ...But you don't have [X]Emacs 19.34, 19.15, or 20+
1412              ** That's why you see lot of undefined variables.
1413              ** It's a byte compiler issue, nothing to worry about.")
1414               ;; This is part of bytecomp.el in 20.1:
1415               ;;
1416               (put 'custom-declare-variable 'byte-hunk-handler
1417                    'byte-compile-file-form-custom-declare-variable)
1418               (defun byte-compile-file-form-custom-declare-variable (form)
1419                 (if (memq 'free-vars byte-compile-warnings)
1420                     (setq byte-compile-bound-variables
1421                           (cons (nth 1 (nth 1 form))
1422                                 byte-compile-bound-variables))) form))))
1423
1424           nil)
1425          ;; .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. . case 2 ..
1426          (t
1427           (unless (string-match "19.2[0-9]\\|19.3[0-3]\\|19.1[0-4]"
1428                                 (emacs-version))
1429             (message "\
1430 tinylibm.el: ** Too old custom.el; You should upgrade your Emacs."))
1431           ;; We have the old custom-library, hack around it.
1432           (defmacro defgroup (&rest args) nil)
1433           (defmacro defcustom (var value doc &rest args)
1434             (` (defvar (, var) (, value) (, doc))))))))))))
1435
1436 ;;}}}
1437
1438 ;;; ################################################### &byte-optimize ###
1439
1440 ;;{{{ misc
1441
1442 (when (and nil                          ;Disabled now
1443            (null (get 'concat 'byte-optimizer)))
1444   (put  'concat 'byte-optimizer 'tinylibb-byte-optimize-concat)
1445
1446   ;; Like `concat', but this macro expands to optimized form.
1447   ;; Many times you want to divide complex regexps on separate lines like
1448   ;; this
1449   ;;    (looking-at (concat
1450   ;;                  ;; Comment
1451   ;;                  \"regexp-1\"
1452   ;;                  ;; Comment
1453   ;;                  \"regexp-2\"
1454   ;;                  ))
1455   ;;
1456   ;; This is perfectly good way, but won't be optimized in any way:
1457   ;; The compiled version contains `concat' command and separate strings.
1458   ;;
1459   ;; This optimized `concat' macro will expand the ARGS to single string
1460   ;; "regexp-1regexp-2\ if they all are strings.
1461   ;; In other cases it expands to normal `concat' call.
1462   ;;
1463   ;;   (defmacro concat-macro (&rest args)
1464   ;;     (if (every 'stringp args)
1465   ;;         (apply 'concat args)
1466   ;;       (cons 'concat args)))
1467   ;;
1468
1469   (defun tinylibb-byte-optimize-concat (form)
1470     (let ((args (cdr form))
1471           (constant t))
1472       (while (and args constant)
1473         (or (byte-compile-constp (car args))
1474             ;;  Stop there
1475             (setq constant nil))
1476         (setq args (cdr args)))
1477
1478       (if constant
1479           (eval form)
1480         form))))
1481
1482 ;;}}}
1483 ;;{{{ Version
1484
1485 ;;; ......................................................... &version ...
1486
1487 (defconst tinylibb-version
1488   (substring "$Revision: 2.73 $" 11 15)
1489   "Latest version number.")
1490
1491 (defconst tinylibb-version-id
1492   "$Id: tinylibb.el,v 2.73 2007/05/01 17:20:45 jaalto Exp $"
1493   "Latest modification time and version number.")
1494
1495 ;;; ----------------------------------------------------------------------
1496 ;;;
1497 (defun tinylibb-version (&optional arg)
1498   "Show version information. ARG will instruct to print message to echo area."
1499   (interactive "P")
1500   (ti::package-version-info "tinylibb.el" arg))
1501
1502 ;;; ----------------------------------------------------------------------
1503 ;;;
1504 (defun tinylibb-submit-bug-report ()
1505   "Submit bug report."
1506   (interactive)
1507   (ti::package-submit-bug-report
1508    "tinylibb.el"
1509    tinylibb-version-id
1510    '(tinylibb-version-id)))
1511
1512 ;;}}}
1513
1514 ;;; tinylibb.el ends here