test/cedet/srecode-tests.el

   1 ;;; From srecode-fields:
   2
   3 (require 'srecode/fields)
   4
   5 (defvar srecode-field-utest-text
   6   "This is a test buffer.
   7
   8 It is filled with some text."
   9   "Text for tests.")
  10
  11 (defun srecode-field-utest ()
  12   "Test the srecode field manager."
  13   (interactive)
  14   (if (featurep 'xemacs)
  15       (message "There is no XEmacs support for SRecode Fields.")
  16     (srecode-field-utest-impl)))
  17
  18 (defun srecode-field-utest-impl ()
  19   "Implementation of the SRecode field utest."
  20   (save-excursion
  21     (find-file "/tmp/srecode-field-test.txt")
  22
  23     (erase-buffer)
  24     (goto-char (point-min))
  25     (insert srecode-field-utest-text)
  26     (set-buffer-modified-p nil)
  27
  28     ;; Test basic field generation.
  29     (let ((srecode-field-archive nil)
  30           (f nil))
  31
  32       (end-of-line)
  33       (forward-word -1)
  34
  35       (setq f (srecode-field "Test"
  36                              :name "TEST"
  37                              :start 6
  38                              :end 8))
  39
  40       (when (or (not (slot-boundp f 'overlay)) (not (oref f overlay)))
  41         (error "Field test: Overlay info not created for field"))
  42
  43       (when (and (overlay-p (oref f overlay))
  44                  (not (overlay-get (oref f overlay) 'srecode-init-only)))
  45         (error "Field creation overlay is not tagged w/ init flag"))
  46
  47       (srecode-overlaid-activate f)
  48
  49       (when (or (not (overlay-p (oref f overlay)))
  50                 (overlay-get (oref f overlay) 'srecode-init-only))
  51         (error "New field overlay not created during activation"))
  52
  53       (when (not (= (length srecode-field-archive) 1))
  54         (error "Field test: Incorrect number of elements in the field archive"))
  55       (when (not (eq f (car srecode-field-archive)))
  56         (error "Field test: Field did not auto-add itself to the field archive"))
  57
  58       (when (not (overlay-get (oref f overlay) 'keymap))
  59         (error "Field test: Overlay keymap not set"))
  60
  61       (when (not (string= "is" (srecode-overlaid-text f)))
  62         (error "Field test: Expected field text 'is', not %s"
  63                (srecode-overlaid-text f)))
  64
  65       ;; Test deletion.
  66       (srecode-delete f)
  67
  68       (when (slot-boundp f 'overlay)
  69         (error "Field test: Overlay not deleted after object delete"))
  70       )
  71
  72     ;; Test basic region construction.
  73     (let* ((srecode-field-archive nil)
  74            (reg nil)
  75            (fields
  76             (list
  77              (srecode-field "Test1" :name "TEST-1" :start 5 :end 10)
  78              (srecode-field "Test2" :name "TEST-2" :start 15 :end 20)
  79              (srecode-field "Test3" :name "TEST-3" :start 25 :end 30)
  80
  81              (srecode-field "Test4" :name "TEST-4" :start 35 :end 35))
  82             ))
  83
  84       (when (not (= (length srecode-field-archive) 4))
  85         (error "Region Test: Found %d fields.  Expected 4"
  86                (length srecode-field-archive)))
  87
  88       (setq reg (srecode-template-inserted-region "REG"
  89                                                   :start 4
  90                                                   :end 40))
  91
  92       (srecode-overlaid-activate reg)
  93
  94       ;; Make sure it was cleared.
  95       (when srecode-field-archive
  96         (error "Region Test: Did not clear field archive"))
  97
  98       ;; Auto-positioning.
  99       (when (not (eq (point) 5))
 100         (error "Region Test: Did not reposition on first field"))
 101
 102       ;; Active region
 103       (when (not (eq (srecode-active-template-region) reg))
 104         (error "Region Test: Active region not set"))
 105
 106       ;; Various sizes
 107       (mapc (lambda (T)
 108               (if (string= (object-name-string T) "Test4")
 109                   (progn
 110                     (when (not (srecode-empty-region-p T))
 111                       (error "Field %s is not empty"
 112                              (object-name T)))
 113                     )
 114                 (when (not (= (srecode-region-size T) 5))
 115                   (error "Calculated size of %s was not 5"
 116                          (object-name T)))))
 117             fields)
 118
 119       ;; Make sure things stay up after a 'command'.
 120       (srecode-field-post-command)
 121       (when (not (eq (srecode-active-template-region) reg))
 122         (error "Region Test: Active region did not stay up"))
 123
 124       ;; Test field movement.
 125       (when (not (eq (srecode-overlaid-at-point 'srecode-field)
 126                      (nth 0 fields)))
 127         (error "Region Test: Field %s not under point"
 128                (object-name (nth 0 fields))))
 129
 130       (srecode-field-next)
 131
 132       (when (not (eq (srecode-overlaid-at-point 'srecode-field)
 133                      (nth 1 fields)))
 134         (error "Region Test: Field %s not under point"
 135                (object-name (nth 1 fields))))
 136
 137       (srecode-field-prev)
 138
 139       (when (not (eq (srecode-overlaid-at-point 'srecode-field)
 140                      (nth 0 fields)))
 141         (error "Region Test: Field %s not under point"
 142                (object-name (nth 0 fields))))
 143
 144       ;; Move cursor out of the region and have everything cleaned up.
 145       (goto-char 42)
 146       (srecode-field-post-command)
 147       (when (srecode-active-template-region)
 148         (error "Region Test: Active region did not clear on move out"))
 149
 150       (mapc (lambda (T)
 151               (when (slot-boundp T 'overlay)
 152                 (error "Overlay did not clear off of of field %s"
 153                        (object-name T))))
 154             fields)
 155
 156       ;; End of LET
 157       )
 158
 159     ;; Test variable linkage.
 160     (let* ((srecode-field-archive nil)
 161            (f1 (srecode-field "Test1" :name "TEST" :start 6 :end 8))
 162            (f2 (srecode-field "Test2" :name "TEST" :start 28 :end 30))
 163            (f3 (srecode-field "Test3" :name "NOTTEST" :start 35 :end 40))
 164            (reg (srecode-template-inserted-region "REG" :start 4 :end 40))
 165            )
 166       (srecode-overlaid-activate reg)
 167
 168       (when (not (string= (srecode-overlaid-text f1)
 169                           (srecode-overlaid-text f2)))
 170         (error "Linkage Test: Init strings are not ="))
 171       (when (string= (srecode-overlaid-text f1)
 172                      (srecode-overlaid-text f3))
 173         (error "Linkage Test: Init string on dissimilar fields is now the same"))
 174
 175       (goto-char 7)
 176       (insert "a")
 177
 178       (when (not (string= (srecode-overlaid-text f1)
 179                           (srecode-overlaid-text f2)))
 180         (error "Linkage Test: mid-insert strings are not ="))
 181       (when (string= (srecode-overlaid-text f1)
 182                      (srecode-overlaid-text f3))
 183         (error "Linkage Test: mid-insert string on dissimilar fields is now the same"))
 184
 185       (goto-char 9)
 186       (insert "t")
 187
 188       (when (not (string= (srecode-overlaid-text f1) "iast"))
 189         (error "Linkage Test: tail-insert failed to captured added char"))
 190       (when (not (string= (srecode-overlaid-text f1)
 191                           (srecode-overlaid-text f2)))
 192         (error "Linkage Test: tail-insert strings are not ="))
 193       (when (string= (srecode-overlaid-text f1)
 194                      (srecode-overlaid-text f3))
 195         (error "Linkage Test: tail-insert string on dissimilar fields is now the same"))
 196
 197       (goto-char 6)
 198       (insert "b")
 199
 200       (when (not (string= (srecode-overlaid-text f1) "biast"))
 201         (error "Linkage Test: tail-insert failed to captured added char"))
 202       (when (not (string= (srecode-overlaid-text f1)
 203                           (srecode-overlaid-text f2)))
 204         (error "Linkage Test: tail-insert strings are not ="))
 205       (when (string= (srecode-overlaid-text f1)
 206                      (srecode-overlaid-text f3))
 207         (error "Linkage Test: tail-insert string on dissimilar fields is now the same"))
 208
 209       ;; Cleanup
 210       (srecode-delete reg)
 211       )
 212
 213     (set-buffer-modified-p nil)
 214
 215     (message "   All field tests passed.")
 216     ))
 217
 218 ;;; From srecode-document:
 219
 220 (require 'srecode/doc)
 221
 222 (defun srecode-document-function-comment-extract-test ()
 223   "Test old comment extraction.
 224 Dump out the extracted dictionary."
 225   (interactive)
 226
 227   (srecode-load-tables-for-mode major-mode)
 228   (srecode-load-tables-for-mode major-mode 'document)
 229
 230   (if (not (srecode-table))
 231       (error "No template table found for mode %s" major-mode))
 232
 233   (let* ((temp (srecode-template-get-table (srecode-table)
 234                                            "function-comment"
 235                                            "declaration"
 236                                            'document))
 237          (fcn-in (semantic-current-tag)))
 238
 239     (if (not temp)
 240         (error "No templates for function comments"))
 241
 242     ;; Try to figure out the tag we want to use.
 243     (when (or (not fcn-in)
 244               (not (semantic-tag-of-class-p fcn-in 'function)))
 245       (error "No tag of class 'function to insert comment for"))
 246
 247     (let ((lextok (semantic-documentation-comment-preceeding-tag fcn-in 'lex))
 248           )
 249
 250       (when (not lextok)
 251         (error "No comment to attempt an extraction"))
 252
 253       (let ((s (semantic-lex-token-start lextok))
 254             (e (semantic-lex-token-end lextok))
 255             (extract nil))
 256
 257         (pulse-momentary-highlight-region s e)
 258
 259         ;; Extract text from the existing comment.
 260         (setq extract (srecode-extract temp s e))
 261
 262         (with-output-to-temp-buffer "*SRECODE DUMP*"
 263           (princ "EXTRACTED DICTIONARY FOR ")
 264           (princ (semantic-tag-name fcn-in))
 265           (princ "\n--------------------------------------------\n")
 266           (srecode-dump extract))))))