cgit.sxemacs.org Git - packages/blob - xemacs-packages/zenirc/src/zenirc-fill.el

   1 ;;; zenirc-fill.el --- fill messages in zenirc
   2
   3 ;; Copyright (C) 1995 Noah S. Friedman
   4 ;; Copyright (C) 1995, 1996, 1997, 1998 Per Persson
   5
   6 ;; Author: Noah Friedman <friedman@prep.ai.mit.edu>
   7 ;;         Per Persson <pp@sno.pp.se>
   8 ;; Maintainer: pp@sno.pp.se
   9 ;; Keywords: extensions
  10 ;; Created: 1995-03-16
  11
  12 ;; This program is free software; you can redistribute it and/or modify
  13 ;; it under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation; either version 2, or (at your option)
  15 ;; any later version.
  16 ;;
  17 ;; This program is distributed in the hope that it will be useful,
  18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;; GNU General Public License for more details.
  21 ;;
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with this program; if not, you can either send email to this
  24 ;; program's maintainer or write to: The Free Software Foundation,
  25 ;; Inc.; 675 Massachusetts Avenue; Cambridge, MA 02139, USA.
  26
  27 ;;; Commentary:
  28 ;;; Code:
  29
  30 (require 'zenirc)
  31
  32 (defvar zenirc-fill-mode nil
  33   "*If non-nil, then fill messages fitting `zenirc-fill-message-categories'.
  34 This is buffer-local.")
  35 (make-variable-buffer-local 'zenirc-fill-mode)
  36
  37 (defvar zenirc-fill-region-function 'zenirc-wrap-region
  38   "*Function to use for filling.")
  39
  40 (defvar zenirc-fill-prefix " | "
  41   "*String for filling to insert at front of new lines, or nil for none.")
  42
  43 (defvar zenirc-fill-static 12
  44   "*How many chars into first the line the first word should end.
  45 This will look totally ridicolous if you don't strip away !user@host from
  46 PRIVMSG and NOTICE")
  47
  48 (defvar zenirc-fill-column (- (window-width) 2)
  49   "*Column beyond which line-wrapping should happen in zenirc buffers.")
  50
  51 (defvar zenirc-fill-message-categories
  52   '(privmsg privmsg_you notice notice_you privmsg_nochannel
  53             notice_nochannel ctcp_action)
  54   "*ZenIRC message categories to fill as paragraphs.
  55 This should be a list consisting of symbols corresponding to the type of
  56 messages in the message catalog which should be filled as paragraphs.
  57 For example, private messages (`privmsg') and notices (`notice') are good
  58 choices.
  59
  60 If this variable is set to `t', then all messages are filled.
  61 If this variable is set to `nil', then no messages are filled.")
  62
  63 (defvar zenirc-fill-nonstandard-message-categories-p nil
  64   "If non-nil, then fill messages that are not in a standard category.
  65 That is, fill messages which did not originate from the message catalog,
  66 and thus have no category symbol.")
  67
  68 \f
  69 (defun zenirc-fill-mode (&optional prefix)
  70   "Enable or disable line wrapping of irc messages.
  71
  72 A negative prefix argument disables this mode.
  73 A non-negative prefix argument enables it.
  74 If no prefix argument is given, toggle the current state of the mode.
  75
  76 The user may also enable or disable this mode simply by setting the
  77 variable of the same name."
  78   (interactive "P")
  79   (cond
  80    ((null prefix)
  81     (setq zenirc-fill-mode (not zenirc-fill-mode)))
  82    ((>= (prefix-numeric-value prefix) 0)
  83     (setq zenirc-fill-mode t))
  84    (t
  85     (setq zenirc-fill-mode nil)))
  86   (cond ((not (interactive-p)))
  87         (zenirc-fill-mode
  88          (message "zenirc-fill-mode is enabled"))
  89         (t
  90          (message "zenirc-fill-mode is disabled")))
  91   zenirc-fill-mode)
  92
  93 ;; "normal" filling function.
  94 (defun zenirc-fill-region (beg end win-width)
  95   (let* ((fill-prefix zenirc-fill-prefix)
  96          (fill-column zenirc-fill-column))
  97     (fill-region-as-paragraph (point-min) (1- (point-max))))
  98     ;; this filling function adds an unnecessary newline.
  99     (goto-char (point-max))
 100     (delete-char -1))
 101
 102 ;; This is like the normal filling routines except that it doesn't squash
 103 ;; whitespace (except at line breaks).  This will make ascii barphics and
 104 ;; other random spaced crap easier to see.
 105 (defun zenirc-wrap-region (beg end win-width)
 106   (interactive "r")
 107   (save-match-data
 108     (save-excursion
 109       (save-restriction
 110         (narrow-to-region beg end)
 111         (let* ((ws "[ \t]")
 112                (prefix-length (length zenirc-fill-prefix))
 113                (fill-column (max (or zenirc-fill-column
 114                                      (- win-width 2))
 115                                  prefix-length))
 116                line-beg)
 117           (goto-char beg)
 118           (while (< (point) (point-max))
 119             (beginning-of-line)
 120             (setq line-beg (+ (point) prefix-length))
 121             (cond ((< fill-column (- (point-max) (point)))
 122                    (forward-char fill-column)
 123                    (cond ((or (memq (char-after (point)) '(32 ?\t))
 124                               (re-search-backward ws line-beg t)
 125                               (re-search-forward ws (point-max) t))
 126                           (just-one-space)
 127                           (delete-char -1)
 128                           (insert "\n" (or zenirc-fill-prefix "")))
 129                          (t
 130                           (goto-char (point-max)))))
 131                   (t
 132                    (goto-char (point-max))))))))))
 133
 134 ;; This adds whitespaces before the first word on every line but the first
 135 ;; one to match up with the length of the first word on the first line.
 136 (defun zenirc-wrap-region-dynamic (beg end win-width)
 137   (interactive "r")
 138   (save-match-data
 139     (save-excursion
 140       (save-restriction
 141         ;; trim trailing whitespace
 142         (goto-char (- end 1))
 143         (just-one-space)
 144         (if (< (+ beg 1) (point))
 145             (delete-char -1))
 146         (setq end (point))
 147
 148         (narrow-to-region beg end)
 149         (goto-char beg)
 150         (let* ((ws "[ \t]")
 151                ; set the length of the prefix
 152                (prefix-length
 153                 (or (and (search-forward " " end t)
 154                          (- (match-end 0) beg))
 155                     0))
 156
 157                ; how many columns zenirc-wrap-region should keep inside
 158                (fill-column (max (or zenirc-fill-column
 159                                      (- win-width 2))
 160                                  (or prefix-length 0)))
 161                line-beg)
 162           (goto-char beg)
 163           ; start wrapping of the actual message, after first word
 164           (while (< (point) (point-max))
 165             (beginning-of-line)
 166             (setq line-beg (+ (point) prefix-length))
 167             (cond ((< fill-column (- (point-max) (point)))
 168                    (forward-char fill-column)
 169                    (cond ((or (memq (char-after (point)) '(32 ?\t))
 170                               (re-search-backward ws line-beg t)
 171                               (re-search-forward ws (point-max) t))
 172                           ; remove all spaces before adding newline
 173                           (just-one-space)
 174                           (delete-char -1)
 175                           (insert
 176                            "\n"
 177                            (make-string prefix-length
 178                                         (string-to-char " "))))
 179                          (t
 180                           (goto-char (point-max)))))
 181                   (t
 182                    (goto-char (point-max))))))))))
 183
 184 ;; This adds whitespaces before the first word on every line so that the
 185 ;; second word on the first line and the first word on every other line
 186 ;; match up with all the other lines (not just in this region).
 187 (defun zenirc-wrap-region-static (beg end win-width)
 188   (interactive "r")
 189   (save-match-data
 190     (save-excursion
 191       (save-restriction
 192         (narrow-to-region beg end)
 193         (goto-char beg)
 194         (let* ((ws "[ \t]")
 195                ; set the length of the prefix
 196                (prefix-length
 197                 (and (search-forward " " end t)
 198                      (- (match-end 0) beg)))
 199                ; how many columns zenirc-wrap-region should keep inside
 200                (fill-column (max (or zenirc-fill-column
 201                                      (- win-width 2))
 202                                  prefix-length))
 203                line-beg)
 204           (goto-char beg)
 205           (if (<= prefix-length zenirc-fill-static)
 206               (progn
 207                 (insert (make-string
 208                          (- zenirc-fill-static prefix-length)
 209                          (string-to-char " ")))
 210                 ; update the length of the prefix, as it is static
 211                 (setq prefix-length zenirc-fill-static)))
 212           ; start wrapping of the actual message, after first word
 213           (while (< (point) (point-max))
 214             (beginning-of-line)
 215             (setq line-beg (+ (point) prefix-length))
 216             (cond ((< fill-column (- (point-max) (point)))
 217                    (forward-char fill-column)
 218                    (cond ((or (memq (char-after (point)) '(32 ?\t))
 219                               (re-search-backward ws line-beg t)
 220                               (re-search-forward ws (point-max) t))
 221                           ; remove all spaces before adding newline
 222                           (just-one-space)
 223                           (delete-char -1)
 224                           (insert
 225                            "\n"
 226                            (make-string zenirc-fill-static
 227                                           (string-to-char " "))))
 228                          (t
 229                           (goto-char (point-max)))))
 230                   (t
 231                    (goto-char (point-max))))))))))
 232
 233
 234 (defvar zenirc-window-last-width 80)
 235 (defun zenirc-fill-message (proc sym string)
 236   (let* ((w (and proc
 237                  (get-buffer-window (process-buffer proc) t)))
 238          (win-width (if w
 239                         (setq zenirc-window-last-width (window-width w))
 240                       zenirc-window-last-width)))
 241     (and zenirc-fill-mode
 242          (cond ((eq zenirc-fill-message-categories t))
 243                ((null sym)
 244                 zenirc-fill-nonstandard-message-categories-p)
 245                ((memq sym zenirc-fill-message-categories))
 246                (t nil))
 247          (funcall zenirc-fill-region-function
 248                   (point-min) (point-max) win-width))))
 249 \f
 250 (defvar zenirc-fill-outgoing-mode nil
 251   "*If non-nil, then fill outgoing PRIVMSG/NOTICEs.
 252 This is buffer-local.")
 253 (make-variable-buffer-local 'zenirc-fill-outgoing-mode)
 254
 255 (defvar zenirc-fill-outgoing-prefix "-> "
 256   "*What do add before outgoing lines.")
 257
 258 (defun zenirc-fill-outgoing-mode (&optional prefix)
 259   "Enable or disable line wrapping of outgoing PRIVMSG/NOTICEs.
 260
 261 A negative prefix argument disables this mode.
 262 No argument or any non-negative argument enables it.
 263
 264 The user may also enable or disable this mode simply by setting the
 265 variable of the same name."
 266   (interactive "P")
 267   (cond
 268    ((null prefix)
 269     (setq zenirc-fill-outgoing-mode (not zenirc-fill-outgoing-mode)))
 270    ((>= (prefix-numeric-value prefix) 0)
 271     (setq zenirc-fill-outgoing-mode t))
 272    (t
 273     (setq zenirc-fill-outgoing-mode nil)))
 274   (cond ((not (interactive-p)))
 275         (zenirc-fill-outgoing-mode
 276          (message "zenirc-fill-outgoing-mode is enabled"))
 277         (t
 278          (message "zenirc-fill-outgoing-mode is disabled")))
 279   zenirc-fill-outgoing-mode)
 280
 281 (defun zenirc-fill-outgoing (beg end str)
 282   (if zenirc-fill-outgoing-mode
 283       (save-excursion
 284         (goto-char beg)
 285         ; if the outgoing line isn't a command, just insert the prefix
 286         (if (not (= (aref str 0) zenirc-command-char))
 287             (progn
 288               (insert zenirc-fill-outgoing-prefix)
 289               (save-restriction
 290                 (narrow-to-region beg end)
 291                 (funcall zenirc-fill-region-function
 292                          beg end (window-width))))
 293           (let
 294               ; if the outgoing line was a command, parse out the
 295               ; actual command and the argument/text.
 296               ((command (car (zenirc-parse-firstword
 297                               (substring str 1))))
 298                (text (cdr (zenirc-parse-firstword str))))
 299             (cond
 300              ; if the command was one of 'm', 'msg' or 'privmsg',
 301              ; do some fanzy parsing and change the line a bit.
 302              ((string-match "\\(^m$\\|^msg$\\|^privmsg$\\)" command)
 303               (delete-region beg end)
 304               (insert zenirc-fill-outgoing-prefix
 305                       "*" (car (zenirc-parse-firstword text)) "* "
 306                       (cdr (zenirc-parse-firstword text)))
 307               (save-restriction
 308                 (narrow-to-region beg end)
 309                 (funcall zenirc-fill-region-function
 310                          beg end (window-width)))))))
 311 )))
 312
 313 \f
 314 (defvar zenirc-command-resize-hook '(zenirc-command-resize))
 315
 316 ;; /resize [width]
 317 (defun zenirc-command-resize (proc cmd)
 318   (if (string= (cdr cmd) "")
 319       (setq zenirc-fill-column (- (window-width) 2))
 320     (setq zenirc-fill-column (cdr cmd))))
 321 \f
 322 (provide 'zenirc-fill)
 323
 324 (zenirc-add-hook 'zenirc-message-hook 'zenirc-fill-message)
 325 (zenirc-add-hook 'zenirc-send-line-hook 'zenirc-fill-outgoing)
 326
 327 (or (assq 'zenirc-fill-mode minor-mode-alist)
 328     (setq minor-mode-alist
 329           (cons (list 'zenirc-fill-mode " Zfill") minor-mode-alist)))
 330
 331 ;;; zenirc-fill.el ends here
 332