ew-data.el

   1 (require 'ew-var)
   2 (require 'ew-util)
   3 (provide 'ew-data)
   4
   5 (defun ew-make-anchor (column str)
   6   (let ((anchor (make-symbol str)))
   7     (put anchor 'anchor anchor)
   8     (put anchor 'type 'ew:*anchor*)
   9     (put anchor 'prev-frag anchor)
  10     (put anchor 'next-frag anchor)
  11     (put anchor 'column column)
  12     (put anchor 'line-length 0)
  13     anchor))
  14
  15 (defun ew-terminate (anchor)
  16   (let ((frag (get anchor 'prev-frag))
  17         (line-length (get anchor 'column)))
  18     (while (null (get frag 'line-length))
  19       (put frag 'line-length line-length)
  20       (setq frag (get frag 'prev-frag)))))
  21
  22 (defsubst ew-add-frag (anchor start end type)
  23   (let ((frag (make-symbol (substring (symbol-name anchor) start end))))
  24     (put frag 'anchor anchor)
  25     (put frag 'type type)
  26     (put frag 'prev-frag (get anchor 'prev-frag))
  27     (put frag 'next-frag anchor)
  28     (put (get anchor 'prev-frag) 'next-frag frag)
  29     (put anchor 'prev-frag frag)
  30     (put frag 'decode (or (get type 'decode) 'ew-decode-none))
  31     (if (string-match "\r\n\\(.*\r\n\\)*" (symbol-name frag))
  32         (let ((prev-line-length (+ (get anchor 'column) (match-beginning 0)))
  33               (next-line-column (- (length (symbol-name frag)) (match-end 0)))
  34               (tmp frag))
  35           (while (null (get tmp 'line-length))
  36             (put tmp 'line-length prev-line-length)
  37             (setq tmp (get tmp 'prev-frag)))
  38           (put anchor 'column next-line-column))
  39       (put anchor 'column (+ (get anchor 'column) (length (symbol-name frag)))))
  40     frag))
  41
  42 ;;; listup
  43
  44 (defun ew-frag-list (anchor)
  45   (let ((res ())
  46         (tmp (get anchor 'prev-frag)))
  47     (while (not (eq anchor tmp))
  48       (setq res (cons tmp res)
  49             tmp (get tmp 'prev-frag)))
  50     res))
  51
  52 (defun ew-pair-list (anchor)
  53   (mapcar
  54    (lambda (frag)
  55      (cons (symbol-value (get frag 'type))
  56            frag))
  57    (ew-frag-list anchor)))
  58
  59 (defun ew-separate-eword (frag1 frag2 targets)
  60   (while (not (eq frag1 frag2))
  61     (when (and (memq (get frag1 'type) targets)
  62                (string-match ew-encoded-word-regexp
  63                              (symbol-name frag1))
  64                (or (< 0 (match-beginning 0))
  65                    (< (match-end 0) (length (symbol-name frag1)))))
  66       (let ((atom (symbol-name frag1))
  67             (start (match-end 0))
  68             result
  69             frag)
  70         (when (< 0 (match-beginning 0))
  71           (setq frag (make-symbol (substring atom 0 (match-beginning 0)))
  72                 result (ew-rcons* result frag)))
  73         (setq frag (make-symbol (substring atom (match-beginning 0) (match-end 0)))
  74               result (ew-rcons* result frag))
  75         (when (cdr result)
  76           (put frag 'prev-frag (cadr result))
  77           (put (cadr result) 'next-frag frag)
  78           (setq frag (cadr result)))
  79         (put frag 'prev-frag (get frag1 'prev-frag))
  80         (put (get frag1 'prev-frag) 'next-frag frag)
  81         (while (string-match ew-encoded-word-regexp atom start)
  82           (when (< start (match-beginning 0))
  83             (setq frag (make-symbol (substring atom start (match-beginning 0)))
  84                   result (ew-rcons* result frag))
  85             (put frag 'prev-frag (cadr result))
  86             (put (cadr result) 'next-frag frag))
  87           (setq frag (make-symbol (substring atom (match-beginning 0) (match-end 0)))
  88                 result (ew-rcons* result frag)
  89                 start (match-end 0))
  90           (put frag 'prev-frag (cadr result))
  91           (put (cadr result) 'next-frag frag))
  92         (when (< start (length (symbol-name frag1)))
  93           (setq frag (make-symbol (substring atom start))
  94                 result (ew-rcons* result frag))
  95           (put frag 'prev-frag (cadr result))
  96           (put (cadr result) 'next-frag frag))
  97         (setq frag (car result))
  98         (put frag 'next-frag (get frag1 'next-frag))
  99         (put (get frag1 'next-frag) 'prev-frag frag)
 100         (while result
 101           (setq frag (car result)
 102                 result (cdr result))
 103           (put frag 'anchor (get frag1 'anchor))
 104           (put frag 'type (get frag1 'type))
 105           (put frag 'decode (get frag1 'decode))
 106           (put frag 'line-length (get frag1 'line-length)))))
 107     (setq frag1 (get frag1 'next-frag))))
 108
 109 ;;; phrase marking
 110
 111 (defun ew-mark-phrase (frag1 frag2)
 112   (when ew-decode-sticked-encoded-word
 113     (ew-separate-eword
 114      frag1 frag2
 115      (if ew-decode-quoted-encoded-word
 116          '(ew:atom
 117            ew:qs-texts)
 118        '(ew:atom)))
 119     (setq frag1 (get (get frag1 'prev-frag) 'next-frag)))
 120   (while (not (eq frag1 frag2))
 121     (setq frag2 (get frag2 'prev-frag))
 122     (unless (ew-comment-frag-p frag2)
 123       (put frag2 'decode 'ew-decode-phrase)))
 124   (while (not (ew-token-last-frag-p
 125                (setq frag2 (get frag2 'prev-frag))))
 126     (unless (ew-comment-frag-p frag2)
 127       (put frag2 'decode 'ew-decode-phrase))))
 128
 129 ;;; frag predicate
 130
 131 (defun ew-token-last-frag-p (frag)
 132   (member (get frag 'type)
 133           '(ew:*anchor*
 134             ew:lt
 135             ew:gt
 136             ew:at
 137             ew:comma
 138             ew:semicolon
 139             ew:colon
 140             ew:dot
 141             ew:atom
 142             ew:qs-end
 143             ew:dl-end)))
 144
 145 (defun ew-comment-frag-p (frag)
 146   (member (get frag 'type)
 147           '(ew:cm-begin
 148             ew:cm-end
 149             ew:cm-nested-begin
 150             ew:cm-nested-end
 151             ew:cm-texts
 152             ew:cm-wsp
 153             ew:cm-fold
 154             ew:cm-qfold
 155             ew:cm-qpair)))
 156
 157 (defun ew-special-frag-p (frag)
 158   (member (get frag 'type)
 159           '(ew:lt
 160             ew:gt
 161             ew:at
 162             ew:comma
 163             ew:semicolon
 164             ew:colon
 165             ew:dot
 166             ew:qs-begin
 167             ew:qs-end
 168             ew:dl-begin
 169             ew:dl-end
 170             ew:cm-begin
 171             ew:cm-end)))