cgit.sxemacs.org Git - packages/blob - xemacs-packages/tm/tl-str.el

   1 ;;; tl-str.el --- Emacs Lisp Library module about string
   2
   3 ;; Copyright (C) 1995,1996,1997 Free Software Foundation, Inc.
   4
   5 ;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
   6 ;; Version: $Id: tl-str.el,v 1.1.1.1 1998-01-14 06:27:57 steve Exp $
   7 ;; Keywords: string
   8
   9 ;; This file is part of tl (Tiny Library).
  10
  11 ;; This program is free software; you can redistribute it and/or
  12 ;; modify it under the terms of the GNU General Public License as
  13 ;; published by the Free Software Foundation; either version 2, or (at
  14 ;; your option) any later version.
  15
  16 ;; This program is distributed in the hope that it will be useful, but
  17 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  19 ;; General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  24 ;; Boston, MA 02111-1307, USA.
  25
  26 ;;; Code:
  27
  28 (require 'emu)
  29 (require 'tl-list)
  30
  31
  32 ;;; @ converter
  33 ;;;
  34
  35 (defun expand-char-ranges (str)
  36   (let ((i 0)
  37         (len (length str))
  38         chr pchr nchr
  39         (dest ""))
  40     (while (< i len)
  41       (setq chr (elt str i))
  42       (cond ((and pchr (eq chr ?-))
  43              (setq pchr (1+ pchr))
  44              (setq i (1+ i))
  45              (setq nchr (elt str i))
  46              (while (<= pchr nchr)
  47                (setq dest (concat dest (char-to-string pchr)))
  48                (setq pchr (1+ pchr))
  49                )
  50              )
  51             (t
  52              (setq dest (concat dest (char-to-string chr)))
  53              ))
  54       (setq pchr chr)
  55       (setq i (1+ i))
  56       )
  57     dest))
  58
  59
  60 ;;; @ space
  61 ;;;
  62
  63 (defun eliminate-top-spaces (str)
  64   "Eliminate top sequence of space or tab and return it. [tl-str.el]"
  65   (if (string-match "^[ \t]+" str)
  66       (substring str (match-end 0))
  67     str))
  68
  69 (defun eliminate-last-spaces (str)
  70   "Eliminate last sequence of space or tab and return it. [tl-str.el]"
  71   (if (string-match "[ \t]+$" str)
  72       (substring str 0 (match-beginning 0))
  73     str))
  74
  75 (defun replace-space-with-underline (str)
  76   (mapconcat (function
  77               (lambda (arg)
  78                 (char-to-string
  79                  (if (eq arg ?\ )
  80                      ?_
  81                    arg)))) str "")
  82   )
  83
  84
  85 ;;; @ version
  86 ;;;
  87
  88 (defun version-to-list (str)
  89   (if (string-match "[0-9]+" str)
  90       (let ((dest
  91              (list
  92               (string-to-number
  93                (substring str (match-beginning 0)(match-end 0))
  94                ))))
  95         (setq str (substring str (match-end 0)))
  96         (while (string-match "^\\.[0-9]+" str)
  97           (setq dest
  98                 (cons
  99                  (string-to-number
 100                   (substring str (1+ (match-beginning 0))(match-end 0)))
 101                  dest))
 102           (setq str (substring str (match-end 0)))
 103           )
 104         (nreverse dest)
 105         )))
 106
 107 (defun version< (v1 v2)
 108   (or (listp v1)
 109       (setq v1 (version-to-list v1))
 110       )
 111   (or (listp v2)
 112       (setq v2 (version-to-list v2))
 113       )
 114   (catch 'tag
 115     (while (and v1 v2)
 116       (cond ((< (car v1)(car v2))
 117              (throw 'tag v2)
 118              )
 119             ((> (car v1)(car v2))
 120              (throw 'tag nil)
 121              ))
 122       (setq v1 (cdr v1)
 123             v2 (cdr v2))
 124       )
 125     v2))
 126
 127 (defun version<= (v1 v2)
 128   (or (listp v1)
 129       (setq v1 (version-to-list v1))
 130       )
 131   (or (listp v2)
 132       (setq v2 (version-to-list v2))
 133       )
 134   (catch 'tag
 135     (while (and v1 v2)
 136       (cond ((< (car v1)(car v2))
 137              (throw 'tag v2)
 138              )
 139             ((> (car v1)(car v2))
 140              (throw 'tag nil)
 141              ))
 142       (setq v1 (cdr v1)
 143             v2 (cdr v2))
 144       )
 145     (or v2 (and (null v1)(null v2)))
 146     ))
 147
 148 (defun version> (v1 v2)
 149   (or (listp v1)
 150       (setq v1 (version-to-list v1))
 151       )
 152   (or (listp v2)
 153       (setq v2 (version-to-list v2))
 154       )
 155   (catch 'tag
 156     (while (and v1 v2)
 157       (cond ((> (car v1)(car v2))
 158              (throw 'tag v1)
 159              )
 160             ((< (car v1)(car v2))
 161              (throw 'tag nil)
 162              ))
 163       (setq v1 (cdr v1)
 164             v2 (cdr v2))
 165       )
 166     v1))
 167
 168 (defun version>= (v1 v2)
 169   (or (listp v1)
 170       (setq v1 (version-to-list v1))
 171       )
 172   (or (listp v2)
 173       (setq v2 (version-to-list v2))
 174       )
 175   (catch 'tag
 176     (while (and v1 v2)
 177       (cond ((> (car v1)(car v2))
 178              (throw 'tag v1)
 179              )
 180             ((< (car v1)(car v2))
 181              (throw 'tag nil)
 182              ))
 183       (setq v1 (cdr v1)
 184             v2 (cdr v2))
 185       )
 186     (or v1 (and (null v1)(null v2)))
 187     ))
 188
 189
 190 ;;; @ RCS version
 191 ;;;
 192
 193 (defun get-version-string (id)
 194   "Return a version-string from RCS ID. [tl-str.el]"
 195   (and (string-match ",v \\([0-9][0-9.][0-9.]+\\)" id)
 196        (substring id (match-beginning 1)(match-end 1))
 197        ))
 198
 199
 200 ;;; @ file name
 201 ;;;
 202
 203 (defun file-name-non-extension (filename)
 204   (if (string-match "\\.[^.]+$" filename)
 205       (substring filename 0 (match-beginning 0))
 206     filename))
 207
 208 (autoload 'replace-as-filename "filename"
 209   "Return safety filename from STRING.")
 210
 211
 212 ;;; @ symbol
 213 ;;;
 214
 215 (defun symbol-concat (&rest args)
 216   "Return a symbol whose name is concatenation of arguments ARGS
 217 which are string or symbol. [tl-str.el]"
 218   (intern (apply (function concat)
 219                  (mapcar (function
 220                           (lambda (s)
 221                             (cond ((symbolp s) (symbol-name s))
 222                                   ((stringp s) s)
 223                                   )
 224                             ))
 225                          args)))
 226   )
 227
 228
 229 ;;; @ matching
 230 ;;;
 231
 232 (defun top-string-match (pat str)
 233   "Return a list (MATCHED REST) if string PAT is top substring of
 234 string STR. [tl-str.el]"
 235   (if (string-match
 236        (concat "^" (regexp-quote pat))
 237        str)
 238       (list pat (substring str (match-end 0)))
 239     ))
 240
 241 (defun middle-string-match (pat str)
 242   "Return a list (PREVIOUS MATCHED REST) if string PAT is found in
 243 string STR. [tl-str.el]"
 244   (if (equal pat str)
 245       (list nil pat nil)
 246     (if (string-match (regexp-quote pat) str)
 247         (let ((b (match-beginning 0))
 248               (e (match-end 0)) )
 249           (list (if (not (= b 0))
 250                     (substring str 0 b)
 251                   )
 252                 pat
 253                 (if (> (length str) e)
 254                     (substring str e)
 255                   )
 256                 )))))
 257
 258 (defun re-top-string-match (pat str)
 259   "Return a list (MATCHED REST) if regexp PAT is matched as top
 260 substring of string STR. [tl-str.el]"
 261   (if (string-match (concat "^" pat) str)
 262       (let ((e (match-end 0)))
 263         (list (substring str 0 e)(substring str e))
 264         )))
 265
 266
 267 ;;; @ compare
 268 ;;;
 269
 270 (defun string-compare-from-top (str1 str2)
 271   (let* ((len1 (length str1))
 272          (len2 (length str2))
 273          (len (min len1 len2))
 274          (p 0)
 275          c1 c2)
 276     (while (and (< p len)
 277                 (progn
 278                   (setq c1 (sref str1 p)
 279                         c2 (sref str2 p))
 280                   (eq c1 c2)
 281                   ))
 282       (setq p (+ p (char-length c1)))
 283       )
 284     (and (> p 0)
 285          (let ((matched (substring str1 0 p))
 286                (r1 (and (< p len1)(substring str1 p)))
 287                (r2 (and (< p len2)(substring str2 p)))
 288                )
 289            (if (eq r1 r2)
 290                matched
 291              (list 'seq matched (list 'or r1 r2))
 292              )))))
 293
 294
 295 ;;; @ regexp
 296 ;;;
 297
 298 (defun regexp-* (regexp)
 299   (concat regexp "*"))
 300
 301 (defun regexp-or (&rest args)
 302   (concat "\\(" (mapconcat (function identity) args "\\|") "\\)"))
 303
 304
 305 ;;; @ end
 306 ;;;
 307
 308 (provide 'tl-str)
 309
 310 ;;; tl-str.el ends here