(require 'comint)
(defgroup tcl nil
"Major mode for editing tcl/tk code."
:prefix "tcl-"
:group 'languages)
(defcustom tcl-default-application "wish"
"Default tcl/tk application to run in tcl subprocess."
:type 'string
:group 'tcl)
(defcustom tcl-default-command-switches nil
"Command switches for `tcl-default-application'.
Should be a list of strings."
:type '(repeat string)
:group 'tcl)
(defvar tcl-process nil
"The active tcl subprocess corresponding to current buffer.")
(defvar tcl-process-buffer nil
"Buffer used for communication with tcl subprocess for current buffer.")
(defcustom tcl-always-show t
"*Non-nil means display tcl-process-buffer after sending a command."
:type 'boolean
:group 'tcl)
(defvar tcl-mode-map nil
"Keymap used with tcl mode.")
(defvar tcl-prefix-key "\C-c"
"Prefix for all tcl-mode commands.")
(defcustom tcl-mode-hook nil
"Hooks called when tcl mode fires up."
:type 'hook
:group 'tcl)
(defvar tcl-region-start (make-marker)
"Start of special region for tcl communication.")
(defvar tcl-region-end (make-marker)
"End of special region for tcl communication.")
(defcustom tcl-indent-level 4
"Amount by which tcl subexpressions are indented."
:type 'integer
:group 'tcl)
(defcustom tcl-default-eval "eval"
"Default command used when sending regions."
:type 'string
:group 'tcl)
(defvar tcl-mode-menu (make-sparse-keymap "Tcl-Mode")
"Keymap for tcl-mode's menu.")
(defvar tcl-font-lock-keywords
(eval-when-compile
(list
'("\\<\\(itcl_class\\|class\\|method\\|proc\\|body\\)\\>[ \t]*\\(\\sw+\\)?"
(1 font-lock-keyword-face) (2 font-lock-function-name-face nil t))
(concat "\\<\\("
"break\\|c\\(ase\\|on\\(structor\\|tinue\\)\\)\\|de\\(fault\\|structor\\)"
"\\|e\\(lse\\(\\|if\\)\\|rror\\|val\\|xit\\)"
"\\|for\\(\\|_\\(array_keys\\|file\\|recursive_glob\\)"
"\\|each\\)\\|i\\([fn]\\|tcl_class\\)\\|loop"
"\\|namespace e\\(val\\|xport\\)"
"\\|p\\(ackage \\(provide\\|require\\)\\|roc\\)"
"\\|return\\|switch\\|then\\|uplevel\\|while"
"\\)\\>")
(cons (concat "\\<\\("
"common\\|global\\|inherit\\|p\\(r\\(ivate\\|otected\\)\\|ublic\\)"
"\\|upvar\\|variable"
"\\)\\>")
'font-lock-type-face)
))
"Default expressions to highlight in TCL modes.")
(defvar tcl-imenu-generic-expression
'(
(nil "^\\s-*\\(proc\\|body\\)\\s-+\\(\\(\\s_\\|\\sw\\)+\\)" 2)
("Classes" "^\\s-*class\\s-+\\(\\(\\s_\\|\\sw\\)+\\)" 1))
"Imenu generic expression for tcl-mode. See `imenu-generic-expression'.")
(defun tcl-mode ()
"Major mode for editing tcl scripts.
The following keys are bound:
\\{tcl-mode-map}
"
(interactive)
(let ((switches nil)
s)
(kill-all-local-variables)
(setq major-mode 'tcl-mode)
(setq mode-name "TCL")
(set (make-local-variable 'tcl-process) nil)
(set (make-local-variable 'tcl-process-buffer) nil)
(make-local-variable 'tcl-default-command-switches)
(set (make-local-variable 'indent-line-function) 'tcl-indent-line)
(set (make-local-variable 'comment-start) "# ")
(set (make-local-variable 'comment-start-skip) "# *")
(set (make-local-variable 'font-lock-defaults)
'(tcl-font-lock-keywords nil nil ((?_ . "w") (?: . "w"))))
(set (make-local-variable 'imenu-generic-expression)
tcl-imenu-generic-expression)
(setq imenu-case-fold-search nil)
(setq imenu-syntax-alist '((?: . "w")))
(make-local-variable 'tcl-default-eval)
(or tcl-mode-map
(tcl-setup-keymap))
(use-local-map tcl-mode-map)
(set-syntax-table (copy-syntax-table))
(modify-syntax-entry ?# "<")
(modify-syntax-entry ?\n ">")
(save-excursion
(goto-char (point-min))
(if (looking-at "#![ \t]*\\([^ \t]*\\)[ \t]\\(.*[ \t]\\)-f")
(progn
(set (make-local-variable 'tcl-default-application)
(buffer-substring (match-beginning 1)
(match-end 1)))
(if (match-beginning 2)
(progn
(goto-char (match-beginning 2))
(set (make-local-variable 'tcl-default-command-switches) nil)
(while (< (point) (match-end 2))
(setq s (read (current-buffer)))
(if (<= (point) (match-end 2))
(setq tcl-default-command-switches
(append tcl-default-command-switches
(list (prin1-to-string s)))))))))
(while (eq (following-char) ?#)
(forward-line 1))
(or (bobp)
(forward-char -1))
(if (eq (preceding-char) ?\\)
(progn
(forward-char 1)
(if (looking-at "exec[ \t]+\\([^ \t]*\\)[ \t]\\(.*[ \t]\\)*-f")
(progn
(set (make-local-variable 'tcl-default-application)
(buffer-substring (match-beginning 1)
(match-end 1)))
(if (match-beginning 2)
(progn
(goto-char (match-beginning 2))
(set (make-local-variable
'tcl-default-command-switches)
nil)
(while (< (point) (match-end 2))
(setq s (read (current-buffer)))
(if (<= (point) (match-end 2))
(setq tcl-default-command-switches
(append tcl-default-command-switches
(list (prin1-to-string s)))))))))
)))))
(run-hooks 'tcl-mode-hook)))
(defun tcl-setup-keymap ()
"Set up keymap for tcl mode.
If the variable `tcl-prefix-key' is nil, the bindings go directly
to `tcl-mode-map', otherwise they are prefixed with `tcl-prefix-key'."
(setq tcl-mode-map (make-sparse-keymap))
(define-key tcl-mode-map [menu-bar tcl-mode]
(cons "Tcl-Mode" tcl-mode-menu))
(let ((map (if tcl-prefix-key
(make-sparse-keymap)
tcl-mode-map)))
(define-key tcl-mode-map [?}] 'tcl-electric-brace)
(define-key map "\M-e" 'tcl-send-current-line)
(define-key map "\M-r" 'tcl-send-region)
(define-key map "\M-w" 'tcl-send-proc)
(define-key map "\M-a" 'tcl-send-buffer)
(define-key map "\M-q" 'tcl-kill-process)
(define-key map "\M-u" 'tcl-restart-with-whole-file)
(define-key map "\M-s" 'tcl-show-process-buffer)
(define-key map "\M-h" 'tcl-hide-process-buffer)
(define-key map "\M-i" 'tcl-get-error-info)
(define-key map "\M-[" 'tcl-beginning-of-proc)
(define-key map "\M-]" 'tcl-end-of-proc)
(define-key map "\C-\M-s" 'tcl-set-tcl-region-start)
(define-key map "\C-\M-e" 'tcl-set-tcl-region-end)
(define-key map "\C-\M-r" 'tcl-send-tcl-region)
(if tcl-prefix-key
(define-key tcl-mode-map tcl-prefix-key map))
))
(defun tcl-indent-line ()
"Indent current line as tcl code.
Return the amount the indentation changed by."
(let ((indent (tcl-calculate-indentation nil))
beg shift-amt
(case-fold-search nil)
(pos (- (point-max) (point))))
(beginning-of-line)
(setq beg (point))
(skip-chars-forward " \t")
(save-excursion
(while (eq (following-char) ?})
(setq indent (max (- indent tcl-indent-level) 0))
(forward-char 1)
(if (looking-at "\\([ \t]*\\)}")
(progn
(delete-region (match-beginning 1) (match-end 1))
(insert-char ? (1- tcl-indent-level))))))
(setq shift-amt (- indent (current-column)))
(if (zerop shift-amt)
(if (> (- (point-max) pos) (point))
(goto-char (- (point-max) pos)))
(delete-region beg (point))
(indent-to indent)
(if (> (- (point-max) pos) (point))
(goto-char (- (point-max) pos))))
shift-amt))
(defun tcl-calculate-indentation (&optional parse-start)
"Return appropriate indentation for current line as tcl code.
In usual case returns an integer: the column to indent to."
(let ((pos (point)))
(save-excursion
(if parse-start
(setq pos (goto-char parse-start)))
(beginning-of-line)
(if (bobp)
(current-indentation)
(forward-char -1)
(if (eq (preceding-char) ?\\)
(+ (current-indentation)
(progn
(beginning-of-line)
(if (bobp)
(* 2 tcl-indent-level)
(forward-char -1)
(if (not (eq (preceding-char) ?\\))
(* 2 tcl-indent-level)
0))))
(forward-char 1)
(if (re-search-backward
"\\(^[^ \t\n\r#]\\)\\|\\({\\s *[#\n]\\)\\|\\(}\\s *\n\\)"
nil t)
(+ (- (current-indentation)
(if (save-excursion
(beginning-of-line)
(and (not (bobp))
(progn
(forward-char -1)
(eq (preceding-char) ?\\))))
(* 2 tcl-indent-level)
0))
(if (eq (following-char) ?{)
tcl-indent-level
0))
(goto-char pos)
(beginning-of-line)
(forward-line -1)
(current-indentation)))))))
(defun tcl-electric-brace (arg)
"Insert `}' and indent line for tcl."
(interactive "P")
(insert-char ?} (prefix-numeric-value arg))
(tcl-indent-line)
(blink-matching-open))
(defun tcl-beginning-of-proc (&optional arg)
"Move backward to the beginning of a tcl proc (or similar).
With argument, do it that many times. Negative arg -N
means move forward to Nth following beginning of proc.
Returns t unless search stops due to beginning or end of buffer."
(interactive "P")
(or arg
(setq arg 1))
(let ((found nil)
(ret t))
(if (and (< arg 0)
(looking-at "^[^ \t\n#][^\n]*{[ \t]*$"))
(forward-char 1))
(while (< arg 0)
(if (re-search-forward "^[^ \t\n#][^\n]*{[ \t]*$" nil t)
(setq arg (1+ arg)
found t)
(setq ret nil
arg 0)))
(if found
(beginning-of-line))
(while (> arg 0)
(if (re-search-backward "^[^ \t\n#][^\n]*{[ \t]*$" nil t)
(setq arg (1- arg))
(setq ret nil
arg 0)))
ret))
(defun tcl-end-of-proc (&optional arg)
"Move forward to next end of tcl proc (or similar).
With argument, do it that many times. Negative argument -N means move
back to Nth preceding end of proc.
This function just searches for a `}' at the beginning of a line."
(interactive "P")
(or arg
(setq arg 1))
(let ((found nil)
(ret t))
(if (and (< arg 0)
(not (bolp))
(save-excursion
(beginning-of-line)
(eq (following-char) ?})))
(forward-char -1))
(while (> arg 0)
(if (re-search-forward "^}" nil t)
(setq arg (1- arg)
found t)
(setq ret nil
arg 0)))
(while (< arg 0)
(if (re-search-backward "^}" nil t)
(setq arg (1+ arg)
found t)
(setq ret nil
arg 0)))
(if found
(end-of-line))
ret))
(defun tcl-start-process (name program &optional startfile &rest switches)
"Start a tcl process named NAME, running PROGRAM."
(or switches
(setq switches tcl-default-command-switches))
(setq tcl-process-buffer (apply 'make-comint name program startfile switches))
(setq tcl-process (get-buffer-process tcl-process-buffer))
(save-excursion
(set-buffer tcl-process-buffer)
(setq comint-prompt-regexp "^[^% ]*%\\( %\\)* *"))
)
(defun tcl-kill-process ()
"Kill tcl subprocess and its buffer."
(interactive)
(if tcl-process-buffer
(kill-buffer tcl-process-buffer)))
(defun tcl-set-tcl-region-start (&optional arg)
"Set start of region for use with `tcl-send-tcl-region'."
(interactive)
(set-marker tcl-region-start (or arg (point))))
(defun tcl-set-tcl-region-end (&optional arg)
"Set end of region for use with `tcl-send-tcl-region'."
(interactive)
(set-marker tcl-region-end (or arg (point))))
(defun tcl-send-current-line ()
"Send current line to tcl subprocess, found in `tcl-process'.
If `tcl-process' is nil or dead, start a new process first."
(interactive)
(let ((start (save-excursion (beginning-of-line) (point)))
(end (save-excursion (end-of-line) (point))))
(or (and tcl-process
(eq (process-status tcl-process) 'run))
(tcl-start-process tcl-default-application tcl-default-application))
(comint-simple-send tcl-process (buffer-substring start end))
(forward-line 1)
(if tcl-always-show
(display-buffer tcl-process-buffer))))
(defun tcl-send-region (start end)
"Send region to tcl subprocess, wrapped in `eval { ... }'."
(interactive "r")
(or (and tcl-process
(comint-check-proc tcl-process-buffer))
(tcl-start-process tcl-default-application tcl-default-application))
(comint-simple-send tcl-process
(concat tcl-default-eval
" {\n"(buffer-substring start end) "\n}"))
(if tcl-always-show
(display-buffer tcl-process-buffer)))
(defun tcl-send-tcl-region ()
"Send preset tcl region to tcl subprocess, wrapped in `eval { ... }'."
(interactive)
(or (and tcl-region-start tcl-region-end)
(error "tcl-region not set"))
(or (and tcl-process
(comint-check-proc tcl-process-buffer))
(tcl-start-process tcl-default-application tcl-default-application))
(comint-simple-send tcl-process
(concat tcl-default-eval
" {\n"
(buffer-substring tcl-region-start tcl-region-end)
"\n}"))
(if tcl-always-show
(display-buffer tcl-process-buffer)))
(defun tcl-send-proc ()
"Send proc around point to tcl subprocess, wrapped in `eval { ... }'."
(interactive)
(let (beg end)
(save-excursion
(tcl-beginning-of-proc)
(setq beg (point))
(tcl-end-of-proc)
(setq end (point)))
(or (and tcl-process
(comint-check-proc tcl-process-buffer))
(tcl-start-process tcl-default-application tcl-default-application))
(comint-simple-send tcl-process
(concat tcl-default-eval
" {\n"
(buffer-substring beg end)
"\n}"))
(if tcl-always-show
(display-buffer tcl-process-buffer))))
(defun tcl-send-buffer ()
"Send whole buffer to tcl subprocess, wrapped in `eval { ... }'."
(interactive)
(or (and tcl-process
(comint-check-proc tcl-process-buffer))
(tcl-start-process tcl-default-application tcl-default-application))
(if (buffer-modified-p)
(comint-simple-send tcl-process
(concat
tcl-default-eval
" {\n"
(buffer-substring (point-min) (point-max))
"\n}"))
(comint-simple-send tcl-process
(concat "source "
(buffer-file-name)
"\n")))
(if tcl-always-show
(display-buffer tcl-process-buffer)))
(defun tcl-get-error-info ()
"Send string `set errorInfo' to tcl subprocess and display the tcl buffer."
(interactive)
(or (and tcl-process
(comint-check-proc tcl-process-buffer))
(tcl-start-process tcl-default-application tcl-default-application))
(comint-simple-send tcl-process "set errorInfo\n")
(display-buffer tcl-process-buffer))
(defun tcl-restart-with-whole-file ()
"Restart tcl subprocess and send whole file as input."
(interactive)
(tcl-kill-process)
(tcl-start-process tcl-default-application tcl-default-application)
(tcl-send-buffer))
(defun tcl-show-process-buffer ()
"Make sure `tcl-process-buffer' is being displayed."
(interactive)
(display-buffer tcl-process-buffer))
(defun tcl-hide-process-buffer ()
"Delete all windows that display `tcl-process-buffer'."
(interactive)
(delete-windows-on tcl-process-buffer))
(define-key tcl-mode-menu [restart-with-whole-file]
'("Restart With Whole File" . tcl-restart-with-whole-file))
(define-key tcl-mode-menu [kill-process]
'("Kill Process" . tcl-kill-process))
(define-key tcl-mode-menu [hide-process-buffer]
'("Hide Process Buffer" . tcl-hide-process-buffer))
(define-key tcl-mode-menu [get-error-info]
'("Get Error Info" . tcl-get-error-info))
(define-key tcl-mode-menu [show-process-buffer]
'("Show Process Buffer" . tcl-show-process-buffer))
(define-key tcl-mode-menu [end-of-proc]
'("End Of Proc" . tcl-end-of-proc))
(define-key tcl-mode-menu [beginning-of-proc]
'("Beginning Of Proc" . tcl-beginning-of-proc))
(define-key tcl-mode-menu [send-tcl-region]
'("Send Tcl-Region" . tcl-send-tcl-region))
(define-key tcl-mode-menu [set-tcl-regio-end]
'("Set Tcl-Region End" . tcl-set-tcl-region-end))
(define-key tcl-mode-menu [set-tcl-region-start]
'("Set Tcl-Region Start" . tcl-set-tcl-region-start))
(define-key tcl-mode-menu [send-current-line]
'("Send Current Line" . tcl-send-current-line))
(define-key tcl-mode-menu [send-region]
'("Send Region" . tcl-send-region))
(define-key tcl-mode-menu [send-proc]
'("Send Proc" . tcl-send-proc))
(define-key tcl-mode-menu [send-buffer]
'("Send Buffer" . tcl-send-buffer))
(provide 'tcl-mode)