cgit.sxemacs.org Git - packages/blob - xemacs-packages/semantic/sformat.el

   1 ;;; Sformat --- souped up format
   2 ;;
   3 ;; Author: Eric Ludlam (zappo@gnu.org)
   4 ;; Version: 1.4
   5 ;; Keywords: extensions
   6 ;;
   7 ;; Copyright (C) 1994, 1996, 1998, 1999, 2000, 2002 Free Software Foundation
   8 ;;
   9 ;; This program is free software; you can redistribute it and/or modify
  10 ;; it under the terms of the GNU General Public License as published by
  11 ;; the Free Software Foundation; either version 2, or (at your option)
  12 ;; any later version.
  13 ;;
  14 ;; This program is distributed in the hope that it will be useful,
  15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;; GNU General Public License for more details.
  18 ;;
  19 ;; You should have received a copy of the GNU General Public License
  20 ;; along with this program; if not, you can either send email to this
  21 ;; program's author (see below) or write to:
  22 ;;
  23 ;;              The Free Software Foundation, Inc.
  24 ;;              675 Mass Ave.
  25 ;;              Cambridge, MA 02139, USA.
  26 ;;
  27 ;; Please send bug reports, etc. to zappo@gnu.ai.mit.edu.
  28 ;;
  29
  30 ;;; Commentary:
  31 ;;
  32 ;; In some applications configuration strings have % options in them
  33 ;; which permit special strings to be inserted.  There are many other
  34 ;; programs which would also benefit from such configuration, but do
  35 ;; not have it due to the time required to build such an extension.
  36 ;; Sformat fills that need making the creation of such functions
  37 ;; quite simple.
  38
  39 ;;; v 1.3
  40 ;; * If no args are passed, then don't attempt to post-format the string.
  41 ;; * Format reversing functions `sformat-just-before-token-regexp' and
  42 ;;   `sformat-just-after-token-regexp'
  43
  44 ;;; v 1.2
  45 ;; Sformat has been sped up by using string commands (string-match,
  46 ;; and substring) to quickly scan over plain text, and then a slower
  47 ;; character by character scan to handle tokens.
  48
  49 ;;; $Id: sformat.el,v 1.5 2002/05/07 01:31:13 zappo Exp $
  50 ;;
  51 ;; History
  52 ;;
  53 ;; eml: 1998/09/11
  54 ;; XEmacs no longer treats a ?c character as an integer.  Change this
  55 ;; check to look at it as a char-or-string.
  56 ;; eml 8/17/94
  57 ;; Added positional data, and ability to handle lambda functions in
  58 ;; options list for more general use.
  59 ;; eml 5/3/95
  60 ;; Added speed up mentioned above
  61 ;; eml 9/8/96
  62 ;; Fixed error where if sizing number = string length, nothing came out
  63 ;; Added ability to pad a string w/ 0s.  Don't use w/ neg argument. ;)
  64 ;; Added speedup to a list searches
  65
  66 ;;; Code:
  67 (eval-when-compile
  68   ;; Silence the byte-compiler
  69   (defvar newstr nil))
  70
  71 (defvar Sformat-default-format 'Sformat-default-format-method
  72   "Function used when the input param is a string and not a function.
  73 This function must conform to the following parameters:
  74 1 - string to be formatted
  75 2 - A1
  76 3 - A2
  77 4 - A1 default or fn
  78 5 - A2 default or fn")
  79
  80 (defvar Sformat-formatting nil
  81   "This flags when Sformat is currently formatting a string.")
  82
  83 (defun Sformat-point ()
  84   "Return the current offset in the string being formated.
  85 Called from % token lambda expressions when needed."
  86   (length newstr))
  87
  88 (defun Sformat-column ()
  89   "Return the current column inside a string being formatted.
  90 Used from % token lambda expressions."
  91   (let ((ts newstr))
  92     (while (string-match "\\(\n\\)" ts)
  93       (setq ts (substring ts (match-end 1))))
  94     (length ts)))
  95
  96 (defun Sformat (extensions fmt &rest args)
  97   "Provide a simple means of formatting strings with special % options.
  98 This will use EXTENSIONS to fill out FMT, and then pass the
  99 result to #<subr format> with ARGS.  EXTENSIONS is of the form:
 100       '( (?F local-filename A1default A2default)
 101          (?U local-username) )
 102
 103 where F is the character after a %, and 'local-filename is a variable
 104 or function.  If it is a function, it must be able to take 2 numeric
 105 arguments.  The args can be used for whatever purpose you desire for
 106 the function.  A string or variable holding a string will have it's
 107 value inserted just as `Sformat-string-word-format' would cut it up.
 108 This action can be modified by changing what the variable
 109 `Sformat-default-format' points to.  A1default and A2default can be
 110 either default values for A1 or A2, or symbols to be used when cutting
 111 this specific string into little pieces.  Numbers are formatted as per
 112 %d with A#defaults being used (numeric only).  Lambda functions passed
 113 in directly as lists will be evaled with no parameters.  Anything else
 114 will be inserted as %S would with A#defaults being used (numeric
 115 only).
 116
 117 Viable formats would be:
 118    %-10v         - 10 chars, pad left
 119    %.1v %:1v     - first word
 120    %10.2v %10:2v - 10 chars, pad right for first 2 words
 121    %03v          - at least 3 chars, padded w/ zeros at beginning
 122
 123    where v is some format character.  Note that .  and : are interchangeable
 124
 125       (Sformat extensions fmt &rest args)"
 126
 127   ;; verify arguments
 128   (if (not (listp extensions))
 129       (signal 'wrong-type-argument (list 'listp extensions)))
 130   (if (not (stringp fmt))
 131       (signal 'wrong-type-argument (list 'stringp fmt)))
 132
 133   (let ((Sformat-formatting t)          ;Yes, we are formatting something
 134         (cnt 0)                         ;position in string
 135         (tl nil)                        ;temp list of extensions
 136         (ln (length fmt))               ;length of fmt string
 137         (tc nil)                        ;temp char
 138         (newstr "")                     ;the new string
 139         (pcnt nil)                      ;% symbol flag
 140         (dot nil)                       ;. symbol flag
 141         (neg1 nil)                      ;- symbol flag on arg1
 142         (neg2 nil)                      ;- symbol flag on arg2
 143         (zpad nil)                      ;numeric starts /w 0
 144         (A1 nil)                        ;arg 1
 145         (A2 nil))                       ;arg 2
 146     (while (/= (length fmt) 0)
 147       (if (string-match "\\(%\\)" fmt)
 148           (progn
 149             (setq newstr (concat newstr (substring fmt 0 (match-beginning 1))))
 150             (setq fmt (substring fmt (match-end 1)))
 151             (setq pcnt t))
 152         (setq newstr (concat newstr fmt))
 153         (setq fmt ""))
 154       (setq cnt 0)
 155       (while pcnt
 156         (setq tc (aref fmt cnt))
 157         (if (not pcnt)
 158             (if (= tc ?%)
 159                 (setq pcnt t)
 160               (setq newstr (concat newstr (char-to-string tc))))
 161           (cond
 162            ((or (= tc ?.) (= tc ?:))    ;. such as %1.2F
 163             (if dot
 164                 (error "Too many .  or : in %% formatter!")
 165               (setq dot t)))
 166            ((= tc ?-)                   ;- such as %-1F
 167             (if dot
 168                 (if A2 (error "Cannot use '-' in middle of numeric arg")
 169                   (setq neg2 t))
 170               (if A1 (error "Cannot use '-' in middle of numeric arg")
 171                 (setq neg1 t))))
 172            ((and (<= tc ?9) (>= tc ?0)) ;number arg
 173             (if dot
 174                 (progn
 175                   (if (not A2) (setq A2 0))
 176                   (setq A2 (+ (* A2 10) (- tc ?0))))
 177               (if (not A1) (progn
 178                              ;; check for 0 padding
 179                              (if (= tc ?0) (setq zpad t))
 180                              (setq A1 0)))
 181               (setq A1 (+ (* A1 10) (- tc ?0)))))
 182            (t                           ;the F in %F
 183             (setq tl (assoc tc extensions))
 184             ;; negafy A1 and A2 if need be.
 185             (if (and neg1 A1) (setq A1 (- A1)))
 186             (if (and neg2 A2) (setq A2 (- A2)))
 187             ;; if we don't find it, pass through verbatim
 188             (if (not tl)
 189                 (let ((tmpstr (concat "%"
 190                                       (if A1 (format "%d" A1))
 191                                       (if A2 (format ".%d" A2))
 192                                       (char-to-string tc))))
 193                   (setq newstr (concat newstr tmpstr)))
 194               (if (not (char-or-string-p (car tl)))
 195                   (error "Invalid extensions list passed to Sformat"))
 196
 197               (if (and (not A1) (numberp (car (cdr (cdr tl)))))
 198                   (setq A1 (car (cdr (cdr tl)))))
 199               (if (and (not A2) (numberp (car (cdr (cdr (cdr tl))))))
 200                   (setq A2 (car (cdr (cdr (cdr tl))))))
 201
 202               (let* ((v (car (cdr tl)))
 203                      (sym (if (symbolp v) (eval v) v))
 204                      (tmpstr (cond
 205                               ((and (symbolp sym) (fboundp sym))
 206                                (funcall sym A1 A2))
 207                               ((and (listp sym) (equal (car sym) 'lambda))
 208                                (funcall sym))
 209                               ((byte-code-function-p sym)
 210                                (funcall sym))
 211                               ((stringp sym)
 212                                (let ((m1 (car (cdr (cdr tl)))))
 213                                  (if zpad
 214                                      (if m1 (setq m1 (intern
 215                                                       (symbol-name m1)
 216                                                       "-0"))
 217                                        (setq m1 'both-0)))
 218                                  (funcall Sformat-default-format
 219                                           sym A1 A2 m1
 220                                           (car (cdr (cdr (cdr tl)))))))
 221                               ((numberp sym)
 222                                (setq zpad (if zpad "0" ""))
 223                                (format (concat "%"
 224                                                (if A1 (format
 225                                                        (concat zpad"%d")
 226                                                        A1))
 227                                                (if A2 (format ".%d" A2))
 228                                                "d")
 229                                        sym))
 230                               (t
 231                                (format (concat "%"
 232                                                (if A1 (format "%d" A1))
 233                                                (if A2 (format ".%d" A2))
 234                                                "S")
 235                                        sym)))))
 236                 (setq newstr (concat newstr tmpstr))))
 237             (setq A1 nil A2 nil neg1 nil neg2 nil zpad nil dot nil pcnt nil)
 238             )
 239            )
 240           )
 241         (setq cnt (1+ cnt))
 242         )
 243       (setq fmt (substring fmt cnt))
 244       )
 245     (if args (funcall 'format newstr args) newstr)
 246     ))
 247
 248 (defun Sformat-default-format-method (str A1 A2 A1def A2def)
 249   "Format routine used when the format method is a string.
 250 STR is the text to be formated.  A1 and A2 represent the passed in
 251 format adjustors.  (Of the form %A1.A2C) where C is a code, and A1
 252 and A2 are numbers.  A1DEF and A2DEF are default values."
 253   ;; check for numbers in defaults, and nil them if need be
 254   (if (numberp A1def) (setq A1def nil))
 255   (if (numberp A2def) (setq A2def nil))
 256   (Sformat-string-word-format str A1 A2 A1def A2def)
 257   )
 258
 259 ;;; The next few routines are for support to make writing your own
 260 ;; formating routines much easier.
 261
 262 (defun Sformat-string-word-format (str A1 A2 method1 method2)
 263   "Support routine which will adjust STR by the given restrictions.
 264 A1 and A2 are dimension bounds for the string.  METHOD1 and METHOD2 define
 265 how those dimensions are used.
 266
 267 A1 represents character limits, and A2 is based on words where a word is
 268 terminated by METHOD2 regexp.  A1 formatting always overrides
 269 A2 for length.  If A1 is negative, pad right, else pad left to fill to
 270 A1 length.
 271
 272    Values of METHOD1 are:
 273    'fill-only    - If (length STR) < A1, pad (left or right), but do
 274                   not shorten
 275    'fill-only-0  - As above, pad with 0
 276    'shorten-only - If (length STR) > A1, cut back, but do not pad to
 277                   make STR A1 characters
 278    'shorten-only-0 - A convenience
 279    nil, 'both    - If STR is too short, pad, if too long, shorten.
 280    'both-0       - As above, padding with 0
 281
 282    Values of METHOD2 are:
 283    nil, \"[a-zA-Z0-9_]*\"  - cut by word, where a word includes numbers
 284                              and '_'
 285    string (regexp)         - trim out given white space replacing with
 286                              one space, with A2 words in string
 287    'preceeding-space       - if A2, the add space to beginning of str
 288
 289    Other notes:
 290
 291    The word trimmer automatically always leaves white-space in front
 292 of each word, thus choochoo.ultranet.com => choochoo.ultranet.com,
 293 not choochoo ultranet com."
 294
 295   (if (not method1) (setq method1 'both))
 296   (if (not method2) (setq method2 "[a-zA-Z0-9_]*"))
 297
 298    (let* ((pad nil)
 299           (newstr nil)
 300           (rstr nil)
 301           (zpad (string-match "-0" (symbol-name method1)))
 302           (A1fl (and A1 (< A1 0)))
 303          )
 304      (if (and A1 (numberp A1))
 305          (setq A1 (abs A1)))
 306
 307      ;; first, cut by A2, if A2 exists.
 308      (if (or (not A2) (not (stringp method2)))
 309          (setq newstr str)
 310        (let ((notrim (progn
 311                        (string-match "\\(\\[\\)" method2)
 312                        (concat
 313                         (substring method2 0 (match-end 1))
 314                         "^"
 315                         (substring method2 (match-end 1)))
 316                        )))
 317          (while (and (< 0 A2) ( string-match (concat notrim
 318                                                      "\\("
 319                                                      method2
 320                                                      "\\)")
 321                                              str))
 322            (if newstr
 323                (setq newstr (concat newstr
 324                                     (substring str 0 (match-end 1))))
 325              (setq newstr (substring str (match-beginning 1)
 326                                      (match-end 1))))
 327            (setq str (substring str (match-end 1)))
 328            (setq A2 (1- A2)))))
 329      ;; Now, cut up newstr by A1 specs!
 330      (cond
 331       ((stringp method2)
 332        (if (not A1)
 333            (setq rstr newstr)
 334          (if (and (< (length newstr) A1)
 335                   (member method1 '(both both-0 fill-only fill-only-0)))
 336              (progn
 337                ;; fill specifications
 338                (setq pad (make-string (- A1 (length newstr)) (if zpad ?0 ? )))
 339                (if A1fl
 340                    (setq rstr (concat newstr pad))
 341                  (setq rstr (concat pad newstr)))))
 342          ;; cut specifications
 343          (if (and (>= (length newstr) A1)
 344                   (member method1 '(both both-0 shorten-only shorten-only-0)))
 345              (setq rstr (substring newstr 0 A1)))))
 346       ((and (eq (eval method2) 'preceeding-space)
 347             (integerp A2)
 348             (not (eq A2 0))
 349             (> (length newstr) 0))
 350        (setq rstr (concat " " newstr)))
 351       (t
 352        (setq rstr newstr)))
 353
 354      rstr)
 355    )
 356
 357 \f
 358 ;;; Sformat string managers
 359 ;;
 360 ;; These two routines find the string between different % tokens, and
 361 ;; returns them as regular expressions vie regexp-quote.  The result
 362 ;; will allow a program to find text surrounding major parts within a
 363 ;; format string.
 364 ;;
 365 ;; This is useful if you want to examine text inserted with sformat
 366 ;; and extract data stuck in originally.
 367
 368 (defun sformat-just-before-token-regexp (token format)
 369   "Return a search expression for text before TOKEN in FORMAT.
 370 This search string can be used to find the text residing in TOKEN
 371 if it were inserted with FORMAT in the past."
 372   (let ((rs nil) (case-fold-search nil))
 373     (if (string-match (concat "\\(%" (char-to-string token) "\\)") format)
 374         (progn
 375           (setq rs (substring format 0 (match-beginning 1)))
 376           ;; scan for previous tokens and shorten
 377           (while (string-match "\\(\\`\\|[^%]\\)\\(%\\)\\(\\'\\|[^%]\\)" rs)
 378             (setq rs (substring rs (+ (match-end 2) 1))))
 379           (regexp-quote rs))
 380       nil)))
 381
 382 (defun sformat-just-after-token-regexp (token format)
 383   "Return a search expression for text after TOKEN in FORMAT.
 384 This search string can be used to find the text residing in TOKEN
 385 if it were inserted with FORMAT in the past."
 386   (let ((rs nil) (case-fold-search nil))
 387     (if (string-match (concat "\\(%" (char-to-string token) "\\)") format)
 388         (progn
 389           (setq rs (substring format (match-end 1)))
 390           (if (string-match "\\(\\`\\|[^%]\\)\\(%\\)\\(\\'\\|[^%]\\)" rs)
 391               (setq rs (substring rs 0 (match-beginning 2))))
 392           (regexp-quote rs))
 393       nil)))
 394
 395 (provide 'sformat)
 396 ;;; sformat ends here