;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; $Id: sts-mode.el,v 1.10 2002/03/25 13:19:11 svogel Exp m0079 $
;;; sts-mode.el -- major mode for editing StoryServer-Templates
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; Adapted from PHP-Mode from: Fred Yankowski <fcy@acm.org>
;;
;; Keywords: StoryServer, Vignette, Tcl, HTML, TSP

;; sts-mode.el is Copyright (c) 2000-2003 by Stefan Vogel
;; <stefan.vogel@avinci.de>
;;	
;;	This is free software; you can redistribute it and/or modify
;;	it under the terms of the GNU General Public License as
;;	published by the Free Software Foundation; either version 2,
;;	or (at your option) any later version.
;;	
;;	This is distributed in the hope that it will be useful, but
;;	WITHOUT ANY WARRANTY; without even the implied warranty of
;;	MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;	GNU General Public License for more details.
;;	
;;	You should have received a copy of the GNU General Public
;;	License as the file COPYING.  If not, write to the Free
;;	Software Foundation, Inc., 59 Temple Place - Suite 330,
;;	Boston, MA 02111-1307, USA.

;;; Commentary;
;;
;; STS mode is a major mode for editing the StoryServer templates
;; (mixed html and tcl).  It is mostly concerned with setting up syntax
;; coloring via the font-lock library and some imenu-expressions
;;
;; To use STS mode, add this to your ~/.emacs file:
;;
;;	(autoload 'sts-mode "sts-mode" "StoryServer editing mode" t)
;;	(add-to-list 'auto-mode-alist '("\\.sts$" . sts-mode))
;;    ;; or if you dare ".html" (This is the extension provided for
;;       external editors)
;;
;; Furthermore, I have the following hook
;; (add-hook 'sts-mode-hook 
;;		  '(lambda () 
;;			 (local-set-key [M-j] 'newline-and-indent)
;;			 (local-set-key "\C-ci" 'sts-insert-tag)))
;;
;; Repeat the second line for any other filename suffixes that you
;; want to associate with STS mode.  Then, install this file in some
;; directory in your Emacs load-path and run byte-compile-file on it.
;;
;; This is just a first shot for colorizing Html- and Tcl.
;; This mode provides an imenu.

(require 'tempo)                ; essential part of sts-mode
(condition-case nil			    ; menu support, standard in emacs19
    (require 'auc-menu)			; add-on for XEmacs. *why* does this
  (error (require 'easymenu)))  ; package have to have two names?

;; Code:
(defconst sts-mode-version 
  (progn
    (let ((revs "$Revision: 1.10 $")
	  (lastchar 0)) 
      ; revs is a string of single byte characters
      (set 'lastchar (1- (string-width revs)))
      (substring revs 11 lastchar))))

;; user variables
(defgroup sts nil
  "Customizing sts-mode"
  :group 'languages
  :group 'hypermedia
  :group 'local)

(defgroup sts-faces nil
  "Customizing sts-mode custom faces"
  :group 'sts
  :group 'faces)

(defvar sts-tab-width 4
  "*Length for tabs used for indentation")

(defvar sts-html-tag-face 
  (defface sts-html-tag-face
	'((((class color)
		(background dark))
	   (:foreground "deep sky blue" :bold t))
	  (((class color)
		(background light))
	   (:foreground "dodger blue" :bold t))
	  (t
	   (:foreground "dodger blue" :bold t)))
	"Face to use for HTML tags."
	:group 'sts-faces))


(defvar sts-font-lock-keywords
  (eval-when-compile
	(list
	 ;; Avoid use of `keep', since XEmacs will treat it the same as `t'.
	 ;; First fontify the text of a HREF anchor.  It may be overridden later.
	 ;; Anchors in headings will be made bold, for instance 
	 '("<a\\s-+href[^>]*>\\([^>]+\\)</a>" 1 font-lock-warning-face t)
	 '("<\\(/?[A-Za-z0-9]+\\)" 1 sts-html-tag-face t)
	 ;;    '("\\(<\\)\\(/?\\sw+\\)\\( ?[^>]*>\\)" 
	 ;; '("</?\\sw+>?" . font-lock-constant-face) ; <word> or </word>
	 ;;(1 font-lock-constant-face) (2 font-lock-function-name-face)
	 ;; (3 font-lock-constant-face t))
	 ;; SGML things like <!DOCTYPE ...> with possible <!ENTITY...> inside.
     '("<![a-z]+\\>[^<>]*\\(<[^>]*>[^<>]*\\)*>" 0 font-lock-keyword-face t)
	 ;; first word after [, that is a StoryServer-Command and procs
	 '("\\[\\s-*\\(\\sw+\\)" (1 font-lock-type-face t))
	 '("\\(proc\\)" (1 font-lock-type-face t))
	 ;; everything after # or [# until end of line is a comment
	 '("^\\(\\s-*#.*\\)" (1 font-lock-comment-face t))
	 '("\\(\\s-*\\[\\s-*#.*\\)" (1 font-lock-comment-face t))
	 ;; HTML special characters
	 '("&[a-zA-Z0-9#]+;" 0 font-lock-warning-face t)
	 '(sts-match-html-comments 0 font-lock-comment-face t t)
	 '(sts-match-attributes 0 font-lock-variable-name-face t t)
	 ;; next two from html-helper (is this asp-specific??)
     '("[=(&]?[ \t\n]*\\(\"[^\"\n]*\"\\)"  1 font-lock-string-face t)
	 '("\\([\"]\\)" 0 font-lock-string-face t)
	 )))

(defvar sts-menu nil
  "Will be added dynamically.")

(defvar sts-imenu-generic-expression
  '(
	;; \\s-*
    ("Functions" "^\\s-*\\(proc\\)\\s-+\\(\\(\\s_\\|\\s:\\|\\sw\\)+\\)\\s-+" 2)
    ("Namespaces" "\\s-*\\(namespace\\s-+eval\\)\\s-+\\(\\(\\s_\\|\\s:\\|\\sw\\)+\\)\\s-+" 2)
    ("INCLUDE" "INCLUDE LIBNAME \\([^\]\n]+\\)" 1)
    ("SOURCE" "SOURCE \\([^\]\n]+\\)" 1)
    ("COMPONENT" "COMPONENT \\([^\n]+\\)" 1)
    ("Forms" "<\\(form\\|FORM\\) [^>]*?\\(name\\|NAME\\)=\"?\\(\\sw+\\)\"?" 2)
    ("FOREACH" "FOREACH ROW IN \\([^{]+\\)" 1)
    ("SEARCH TABLE" "SEARCH TABLE \\([^ ]+\\) INTO \\([^ ]+\\)" 2))
  "Imenu generic expression for StoryServer-Mode See `imenu-generic-expression'.")

(defvar sts-tempo-tags nil
  "List of tags used for completion.")

(defvar sts-completion-finder
  "\\(\\(<\\|&\\).*\\)\\="
  "Passed to tempo-use-tag-list, used to find tags to complete.")

;; Our basic keymap.
(defvar sts-mode-map (make-sparse-keymap)
  "Keymap for sts")

;; I'd like to have the html <, > tags as a sexp
;; so give < and > matching semantics
(defvar sts-mode-syntax-table nil
  "Syntax table for sts.")

(if sts-mode-syntax-table
	()
  (setq sts-mode-syntax-table (make-syntax-table text-mode-syntax-table))
  (modify-syntax-entry ?< "(>" sts-mode-syntax-table)
  (modify-syntax-entry ?>  ")<" sts-mode-syntax-table))

(defun sts-add-tag (l)
  "Add a new tag to sts-mode and to the menu.
Builds a tempo-template for the tag and puts it into the
appropriate keymap if a key is requested. Format:
`(sts-add-tag '(type keybinding completion-tag menu-name template doc)'
Builds up the menu first in - last entry."
  (let* ((key (nth 1 l))
	 (completer (nth 2 l))
	 (name (nth 3 l))
	 (func (nth 4 l))
	 (tag (nth 5 l))
	 (doc (nth 6 l))
	 (command (tempo-define-template func
					 tag completer doc
					 'sts-tempo-tags)))
	(if (stringp key)			                  ;bind key somewhere?
		(define-key sts-mode-map key command)      ;t:   bind to prefix
	  t)
	(setq sts-menu			                  ;good, cons it in
		  (cons (vector name command t) sts-menu))
	))

;; These tags are an attempt to be HTML/2.0 compliant, with the exception
;; of container <p>, <li>, <dd>, <dt> (we adopt 3.0 behaviour).
;; For reference see <URL:http://www.w3.org/hypertext/WWW/MarkUp/MarkUp.html>

;; order here is significant: within a tag type, menus and mode help
;; go in the reverse order of what you see here. Sorry about that, it's
;; not easy to fix.
(defun sts-create-menu-key ()
  (mapcar
   'sts-add-tag
   '(
	 ;;entities
	 (entity  "\C-c#" "&#" "Ascii Code" "sts-asciicode" ("&#" (r "Ascii: ") ";"))
	 (entity  "\C-c "  "&nbsp;" "Nonbreaking Space"  "sts-space"  ("&nbsp;"))
	 (entity  "\C-c\""  "&quot;" "\""  "sts-quot"  ("&quot;"))
	 (entity "\C-c>" "&gt;" ">" "sts-gt" ("&gt;"))
	 (entity "\C-c<" "&lt;" "<" "sts-lt" ("&lt;"))
	 (entity "\C-cs" "&szlig;" "ß" "sts-szlig" ("&szlig;"))
	 (entity "\C-cu" "&uuml;" "ü" "sts-uuml" ("&uuml;"))
	 (entity "\C-cU" "&Uuml;" "Ü" "sts-Uuml" ("&Uuml;"))
	 (entity "\C-co" "&ouml;" "ö" "sts-ouml" ("&ouml;"))
	 (entity "\C-cO" "&Ouml;" "Ö" "sts-Ouml" ("&Ouml;"))
	 (entity "\C-ca" "&auml;" "ä" "sts-auml" ("&auml;"))
	 (entity "\C-cA" "&Auml;" "Ä" "sts-Auml" ("&Auml;"))
	 (entity "\C-c\&" "&amp;" "Ampersand" "sts-amp" ("&amp;"))
	 (entity "\C-c\C-j" "<br />\n" "Linebreak" "sts-br" ("<br />\n"))
	 (include "\C-c\C-si" "INCLUDE" "INCLUDE" "sts-include" ("INCLUDE LIBNAME " (r "Library: ")n))
	 (search "\C-c\C-ss" "SEARCH" "Search Table" "sts-search" ("SEARCH TABLE " (r "Table: ") " INTO " (r "Into: ") " SQL \""n> p"FROM [SHOW sCurrentDB]"n>"\"]"))
	 (form "\C-c\C-sf" "form" "Form" "sts-form" ("<form name=\"" (r "Name: ") "\" method=\"" (r "Method: ") "\" action=\"" (r "Action: ") "\">"n> p""n>"</form>"n))
	 (table "\C-c\C-st" "table" "Table" "sts-table" ("table cellspacing=\"0\" cellpadding=\"0\" border=\"0\">"n>"<tr>"n> >"<td>"p"</td>"n>"</tr>"n"</table>"n))
	 (body "\C-c\C-sb" "html" "Html-Body" "sts-body" ("<html>"n p"<head>"n>"<title></title>"n"</head>"n"<body>"n"</body>"n"</html>"))
	 (header "\C-c\C-sl" "" "Change Item V1" "sts-topic1" ("<li dat=\""(format-time-string "%d.%m.%Y")"\" autor=\""(user-full-name)"\">"p"</li>"n))
	 (proc "\C-c\C-sp" "" "Prozedur-Header V1" "sts-proc" ("# ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++"n"IF {0} {<proc version=\"1.0\" name=\""p"\">"n"<fkt>Ein_Satz_Beschreibung</fkt>"n"<autor>"(user-full-name)"</autor>"n"<beschreib>"n"Ausfuehrliche_Beschreibung_der_Prozedur"n"</beschreib>"n"<params>"n"  <in>Parameter_die_reingehen:_Name_-_Beschreibung</in>"n"  <inout>Parameter_die_per_Referenz_eingehen</inout>"n"  <out>Rueckgabeparameter</out>"n"</params>"n"<side>Eventuelle_Seiteneffekte</side>"n"</proc>}"n"# ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++"n))
	 (header "" "HEAD" "Std-Templ-Header V0" "sts-header" ("# ----------------------------------------------------------------------"n" | Name:         " (substring (buffer-name) 0 -5) n" | Funktion:     "p n" | "n" | Autor:        " (user-full-name) n" | Datum:        " (format-time-string "%d.%m.%Y") n" | Beschreibung:"n" | "n" | "n" | Aenderungshistorie:"n" | "n" # ----------------------------------------------------------------------]"))
	 (header "\C-c\C-sh" "" "Std-Templ-Header V1" "sts-header1" ("# ------------------------------------------------------------"n"IF {0} {<header version=\"1.0\" name=\""(substring (buffer-name) 0 -5)"\">"n"<fkt>"p"Ein_Satz_Beschreibung_des_Templates</fkt>"n"<autor>"(user-full-name)"</autor>"n"<erstell>"(format-time-string "%d.%m.%Y")"</erstell>"n"<beschreib>"n"Ausfuehrliche_Beschreibung_des_Templates"n"</beschreib>"n"<params>"n"  <in>1_Parameter_der_benoetigt_wird_in_der_Form:_Name_-_Erlaeuterung</in>"n"  <in>2_Parameter</in>"n"  <in>3_Parameter</in>"n"  <out>Parameter_die_zurueckgegeben_werden</out>"n"</params>"n"<hist>"n" <li dat=\"TT.MM.JJJJ\" autor=\"Nachname\">kurze_Beschreibung_der_Aenderung</li>"n"</hist>"n"</header>}"n"# ------------------------------------------------------------"n))
	 )))

;;  (tempo-define-template "sts-proc" '("proc " (r "Name: ") " {" (r "Arguments: ") "}" n> p "global" n> "upvar" n>"return \"\""n"}]" n) "proc" "Insert a procedure" 'sts-tempo-tags)

(defun sts-insert-tab-p (point)
  "Checke ob der Cursor vor dem ersten Zeichen einer Zeile steht!"
  (save-excursion
	(<= (progn (goto-char point) (current-column)) 
		(current-indentation))))

;; TODO: this could be done better?
(defun sts-insert-tag (sTag)
  (interactive "sTag: ")
	(cond ((null mark-active)
		   (progn 
				(insert (format "<%s></%s>" sTag sTag))
				(goto-char (- (point) (length sTag) 3))
				))
		   (t (let ((begin (region-beginning))
				 (end (region-end)))
			 (goto-char (region-end))
			 (insert (format "</%s>" sTag))
			 (goto-char begin)
			 (insert (format "<%s>" sTag))
			 (goto-char (+ end (* 2 (length sTag)) 5))
			 ))))

;; indente always by TAB (4 spaces) (the distinction if
;; TAB is on
;; indent-region (start end column) (when indent-region-function
;; is set (see indent.el) will be by calling indent-according-to-mode,
;; else the indent-region-function will be set on each row.
;; The distinction on region will be done inside the TAB-Keybindings.
;; C-u TAB is equal to S-TAB "unindent"
(defun sts-indent-region (start end column)
  "Indent current line like text-mode. Column is not needed."
  (interactive "r\nP")
  ;; (message "start %s end %s column %s" start end column)
  ;; sollte hier besser count-lines start end benutzt werden?
  (save-excursion
	(save-restriction
	  (let ((start (progn (goto-char start) (beginning-of-line) (point))) 
			(end (progn (goto-char end) (end-of-line) (point)))
			;; je nachdem ob TAB oder S-TAB (S-Tab == C-u  --> column <> nil)
			(diff (if (null column) sts-tab-width (* sts-tab-width -1))))
		(narrow-to-region (goto-char start) end)
		(while (not (eobp))
		  ;; save current-indentation
		  (let ((ci (current-indentation)))
			;; this one deletes everything from beginning of line to first char
			(delete-region (point) (progn (skip-chars-forward " \t") (point)))
			;; now we have to count down end, so that it stops on the right line
			(indent-to (+ ci diff)))
		  (forward-line 1))
		)
		;; don't delete region when we are finished
	  (setq deactivate-mark nil))))

;; Html comments can overflow the buffer if used to hide the code
;; from older browser
(defun  sts-match-html-comments (last)
  "Matches comments in HTML from point to LAST"
  (cond ((search-forward "<!--" last t) ; match inline elsewhere
	 (backward-char 4)
	 (let ((beg (point)))
	   (cond ((search-forward-regexp "--[ \t]*>" last t)
		  (set-match-data (list beg (point)))
		  t )
		 (t nil))))
	(t nil)))

;; match html tag attributes
(defun sts-match-attributes (last)
  "Matches tag attributes in HTML from point to LAST"
  (cond ((search-forward-regexp "[A-Za-z]+=" last t)
		 (let ((endolo (point))
			   (beg (progn (backward-word 1)(point)))
			   (firstop (cond ((search-backward-regexp 
								"<\\(@\\|[A-Za-z]+\\)" 1 t)
							   (point))
							  (t nil)))
			   (firstclo (cond ((search-forward ">" last t)
								(point))
							   (t nil))))
		   (cond (firstop
				  (cond (firstclo 
						 (cond ((and (< firstop beg)
									 (> firstclo endolo))
								(goto-char endolo)
								(set-match-data (list beg endolo))
								t )
							   (t 
								(goto-char endolo) 
								(set-match-data nil)
								t)))
						(t (goto-char endolo)
						   (set-match-data (list beg endolo))
						   t)))
				 (t 
				  (goto-char endolo) 
				  (set-match-data nil)
				  t))))
		(t nil)))

(define-derived-mode sts-mode text-mode "STS"
  "A major mode for editing StoryServer-Templates (mixed Tcl and Html).

Key bindings:
\\{sts-mode-map}"
  (auto-fill-mode nil)
  (setq sts-mode t)
  ;; (setq sts-mode-map (make-sparse-keymap))

  (set-syntax-table sts-mode-syntax-table)
 
  (define-key sts-mode-map [tab] 
	'(lambda () 
	   (interactive)
	   (if (null mark-active)
		   ;; mark is not aktiv: only indent this row
		   ;; if the cursor is not on beginning of row insert a tab
		   (if (sts-insert-tab-p (point))
			   (insert "\t")
			 (progn (sts-indent-region (point) (point) nil)
					;; set cursor und first char of row
					(skip-chars-forward " \t")))
		 ;; mark is aktive, detect the region
		 (sts-indent-region (region-beginning) (region-end) nil)
		 )
	   ))

  ;; see [tab]
  (define-key sts-mode-map [S-tab] 
	'(lambda ()
	   (interactive)
	   (if (null mark-active)
		   ;; we set column to 4, the value really doesn't matter,
		   ;; because we simple want the nagation  a la C-u
		   (progn
			 (sts-indent-region (point) (point) 4)
			 (beginning-of-line)
			 (skip-chars-forward " \t"))
		 (sts-indent-region (region-beginning) (region-end) 4)
		 )))

  (tempo-use-tag-list 'sts-tempo-tags)

  (set (make-local-variable 'tempo-interactive) t)
  (set (make-local-variable 'imenu-auto-rescan) t)
  (set (make-local-variable 'imenu-generic-expression) sts-imenu-generic-expression)
  
  (defvar sts-mode-syntax-table sts-mode-syntax-table)
  ;; underscore and : considered part of word
  (modify-syntax-entry ?_ "w" sts-mode-syntax-table)
  (modify-syntax-entry ?: "w" sts-mode-syntax-table)
  ;; dollar-sign considered punctuation, not part of word
  (modify-syntax-entry ?$ "." sts-mode-syntax-table)

  ;; taken from tcl-mode
  (set (make-local-variable 'font-lock-defaults)
	   '(sts-font-lock-keywords 
		 nil ; KEYWORD-ONLY: no
		 nil ; CASE-FOLD: no (should be yes?)
		 ((?_ . "w") (?: . "w")) ; SYNTAX-ALIST what is this for?
								 ; SYNTAX-BEGIN what for? Here is nil
		 ))
   (setq sts-menu nil)
   (sts-create-menu-key)
   (setq sts-menu (cons "StoryServer" sts-menu))
   (easy-menu-remove sts-menu)
   (easy-menu-define sts-mode-menu-symbol
		      sts-mode-map "StoryServer menus" sts-menu)
   (easy-menu-add sts-menu sts-mode-map)
   (run-hooks 'sts-mode-hook)
)

(unless (boundp 'default)
  (defvar default 'default))
;; Created "default" symbol for GNU Emacs so that both Xemacs and GNU
;; emacs can refer to the default face by a variable named "default".

(unless (boundp 'font-lock-keyword-face)
  (copy-face 'bold 'font-lock-keyword-face))
;; font-lock-keyword-face is sure to be valid now, assuming that the
;; bold face exists

(provide 'sts-mode)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Revision-History:
;; $Log: sts-mode.el,v $
;; Revision 1.10  2002/03/25 13:19:11  svogel
;; Added "Change Item". Thanks to Gabi Zech.
;;
;; Revision 1.9  2002/03/24 13:45:47  svogel
;; Fixed regexp for imenu in FOREACH
;;
;; Revision 1.8  2002/03/17 12:28:41  svogel
;; Fixed imenu for XML-Docu
;;
;; Revision 1.7  2001/02/10 17:53:54  svogel
;; About to change font-lock again
;;
;; Revision 1.6  2001/02/04 15:14:46  svogel
;; Nice try with menues copied from html-helper (way too complex)
;;
;; Revision 1.5  2001/02/04 09:07:32  svogel
;; First shot for customizing.
;;
;; Revision 1.4  2001/02/03 21:13:05  svogel
;; Neue indent-Funktion (alte ist noch als Kommentar drin)
;;
;; Revision 1.3  2000/05/14 09:58:29  m0079
;; Fixed sts-indent
;;
;; Revision 1.2  2000/05/09 21:39:01  m0079
;; sts-indent for indenting added
;;
;; Revision 1.1  2000/04/18 19:31:50  m0079
;; Initial revision
;;
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;