;;;; Test::Class support for PerlySense


(defvar ps/tc/current-method nil
  "The current TEST_METHOD in this buffer")
(make-variable-buffer-local 'ps/tc/current-method)



(defun ps/tc/toggle-current-sub ()
  "Make the sub near point the 'current method', or clear the
'current method' if it's already current."
  (interactive)
  (let ((method-name (ps/get-nearby-sub)))
    (if method-name
        (ps/tc/toggle-current-method method-name)
      (message "No Test::Class method found")
      )))

(defun ps/tc/toggle-current-method (method-name)
  (if (string-equal ps/tc/current-method method-name)
      (progn
        (setq method-name nil)
        (message "Test::Class method: -none-")
        )
    (message "Test::Class method: %s"
             (propertize method-name 'face 'font-lock-function-name-face))
    )
  (setq ps/tc/current-method method-name)
  (ps/tc/redisplay-method method-name)
  )

(defun ps/get-nearby-sub ()
  (let ((sub-name
          (save-excursion
            (end-of-line)
            (and (search-backward-regexp " *sub +\\([_a-z0-9]+\\)" (point-min) t)
                 (buffer-substring-no-properties (match-beginning 1) (match-end 1)))))
         )
    sub-name
    ))

(defun ps/sub-pos (sub-name)
  "Return the buffer position of 'sub sub-name', or nil if none
was found."
  (let ((sub-pos
          (save-excursion
            (goto-char (point-min))
            (and (search-forward-regexp (format " *sub +%s[^_a-z0-9]" sub-name) (point-max) t)
                 (match-beginning 0)))))
    sub-pos))

(defvar ps/tc/current-method-overlay nil
  "The overlay for the current method ")
(make-variable-buffer-local 'ps/tc/current-method-overlay)

(defun ps/tc/redisplay-method (method-name)
  (remove-overlays (point-min) (point-max) 'test-class-method t)

  (let ((sub-pos (ps/sub-pos method-name)))
    (if sub-pos
        (progn
          (setq ps/tc/current-method-overlay (make-overlay sub-pos sub-pos))
          (overlay-put ps/tc/current-method-overlay 'test-class-method t)
          (overlay-put ps/tc/current-method-overlay 'before-string
                       (propertize "Test::Class --> " 'face 'font-lock-comment-face))
          ))))


(global-set-key (format "%stm" ps/key-prefix) 'ps/tc/toggle-current-sub)


; (message "(%s)" ps/tc/current-method)


;;END