cgit.sxemacs.org Git - packages/blob - xemacs-packages/liece/lisp/liece-q-ccl.el

   1 ;;; liece-q-ccl.el --- CTCP binary data quotation in CCL.
   2 ;; Copyright (C) 1998-2000 Daiki Ueno
   3
   4 ;; Author: Daiki Ueno <ueno@unixuser.org>
   5 ;; Created: 1999-01-31
   6 ;; Revised: 1999-01-31
   7 ;; Keywords: IRC, liece, CTCP
   8
   9 ;; This file is part of Liece.
  10
  11 ;; This program is free software; you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation; either version 2, or (at your option)
  14 ;; any later version.
  15
  16 ;; This program is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU 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
  27 ;;; Commentary:
  28 ;;
  29
  30 ;;; Code:
  31
  32 (require 'broken)
  33 (require 'pccl)
  34 (require 'poem)                         ;char-int
  35
  36 (eval-and-compile
  37   (defconst liece-quote-ccl-256-table
  38     (let ((i 0)
  39           table)
  40       (while (< i 256)
  41         (setq table (nconc table (list i))
  42               i (1+ i)))
  43       table)))
  44
  45 (broken-facility ccl-cascading-write
  46   "Emacs CCL write command does not accept more than 2 arguments."
  47   (condition-case nil
  48       (progn
  49         (define-ccl-program cascading-read-test
  50           '(1
  51             (write r0 r1 r2)))
  52         t)
  53     (error nil)))
  54
  55 (define-ccl-program liece-quote-ccl-decode
  56   `(1
  57     (loop
  58       (read-if
  59        (r0 == ?\\)
  60        ((read-if
  61          (r1 == ?\\)
  62          (write r1)
  63          (branch
  64           r1
  65           ,@(mapcar
  66              (lambda (r1)
  67                (cond
  68                 ((= r1 (char-int ?a))
  69                  `(write ?\x01))
  70                 ((= r1 (char-int ?n))
  71                  `(write ?\n))
  72                 ((= r1 (char-int ?r))
  73                  `(write ?\r))
  74                 (t
  75                  (if-broken ccl-cascading-write
  76                      `((write r0)
  77                        (write r1))
  78                    `(write r0 r1)))))
  79              liece-quote-ccl-256-table))))
  80        (write r0))
  81       (repeat))))
  82
  83 (define-ccl-program liece-quote-ccl-encode
  84   `(2
  85     (loop
  86       (read-branch
  87        r0
  88        ,@(mapcar
  89           (lambda (r0)
  90             (cond
  91              ((= r0 (char-int ?\\))
  92               `(write-repeat "\\\\"))
  93              ((= r0 (char-int ?\x01))
  94               `(write-repeat "\\a"))
  95              ((= r0 (char-int ?\n))
  96               `(write-repeat "\\n"))
  97              ((= r0 (char-int ?\r))
  98               `(write-repeat "\\r"))
  99              (t
 100               `(write-repeat r0))))
 101           liece-quote-ccl-256-table)))))
 102
 103 (make-ccl-coding-system
 104  'liece-quote-ccl-cs ?Q "CTCP Quote Decoder/Encoder"
 105  'liece-quote-ccl-decode 'liece-quote-ccl-encode)
 106
 107 (defun liece-quote-ccl-decode-string (string-to-decode)
 108   (decode-coding-string string-to-decode 'liece-quote-ccl-cs))
 109
 110 (defun liece-quote-ccl-encode-string (string-to-encode)
 111   (encode-coding-string string-to-encode 'liece-quote-ccl-cs))
 112
 113 (defun liece-quote-ccl-decode-region (min max)
 114   (decode-coding-region min max 'liece-quote-ccl-cs))
 115
 116 (defun liece-quote-ccl-encode-region (min max)
 117   (encode-coding-region min max 'liece-quote-ccl-cs))
 118
 119 (defalias 'liece-quote-decode-string 'liece-quote-ccl-decode-string)
 120 (defalias 'liece-quote-encode-string 'liece-quote-ccl-encode-string)
 121
 122 (defalias 'liece-quote-decode-region 'liece-quote-ccl-decode-region)
 123 (defalias 'liece-quote-encode-region 'liece-quote-ccl-encode-region)
 124
 125 (provide 'liece-q-ccl)
 126
 127 ;;; liece-q-ccl.el ends here