;;; sdtlinks.el --- Minor mode for handling of SDT links

;; Author: Manfred Persson <manfred.persson@telelogic.se>
;; Keywords: SDT, SOMT, endpoint, link

;;; Copyright by Telelogic AB 1996 - 1998
;;
;; This program 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 of the License, or
;; (at your option) any later version.
;;
;; This program 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
;; along with this program; if not, write to the Free Software
;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.

;;; Commentary:

;;; VERSION:
;;

;;; HISTORY:
;;

;;; INSTALLATION:
;;
;; To use this package, put this file in a Lisp directory known to Emacs
;; (see `load-path'), byte-compile it, and put the line:
;;
;;                      (require 'sdtlinks)
;;
;; in your ~/.emacs file or in the file default.el in the ../lisp directory
;; of the Emacs distribution.

;;; DESCRIPTION:
;;

;;; USAGE:
;;
;; User commands:
;; --------------
;; sdtlinks-mode
;;
;; sdtlinks-create-endpoint
;; sdtlinks-delete-endpoint
;; sdtlinks-follow-link
;; sdtlinks-show-endpoint-in-link-manager
;;
;; Configuration:
;; --------------
;; sdtlinks-endpoint-face
;; sdtlinks-endpoint-with-links-face
;; sdtlinks-mode-hook
;;

;;; Code:

(require 'sdtemacs)

;;;; VARIABLES

(defvar sdtlinks-mode-hook nil)

(make-variable-buffer-local 'sdtlinks-mode)
(put 'sdtlinks-mode 'permanent-local t)

(defvar sdtlinks-mode-map
  (let ((map (make-sparse-keymap)))
    (define-key map "\C-c\C-c" 'sdtlinks-create-endpoint)
    (define-key map "\C-c\C-d" 'sdtlinks-delete-endpoint)
    (define-key map "\C-c\C-f" 'sdtlinks-follow-link)
    (define-key map "\C-c\C-s" 'sdtlinks-show-endpoint-in-link-manager)
    map)
  "Keymap for `sdtlinks-mode'.")

(make-variable-buffer-local 'sdtlinks-endpoints)
(put 'sdtlinks-endpoints 'permanent-local t)

(defvar sdtlinks-anchor-counter 0)
(make-variable-buffer-local 'sdtlinks-anchor-counter)
(put 'sdtlinks-anchor-counter 'permanent-local t)

(make-variable-buffer-local 'sdtlinks-reply-info)
(put 'sdtlinks-reply-info 'permanent-local t)

(defvar sdtlinks-endpoint-string-bc "")
(defvar sdtlinks-reverting nil)

;;;; ENDPOINT MARKERS

(defsubst sdtlinks-endpoint-begin-mark (anchor)
  (concat "<SDT_LINK_ENDPOINT_BEGIN " (number-to-string anchor) " >"))

(defconst sdtlinks-endpoint-begin-mark-regexp
  "<SDT_LINK_ENDPOINT_BEGIN *\\([1-9]+[0-9]*\\) *>")

(defconst sdtlinks-endpoint-end-mark
  "<SDT_LINK_ENDPOINT_END>")

;;;; TYPE FACES FOR ENDPOINTS

;;; Ensure that sdtlinks-endpoint-face is defined
(or (member 'sdtlinks-endpoint-face (face-list))
    (progn
      (make-face 'sdtlinks-endpoint-face)
      (set-face-underline-p 'sdtlinks-endpoint-face t)
      (set-face-foreground 'sdtlinks-endpoint-face "blue")))

;;; Ensure that sdtlinks-endpoint-with-links-face is defined
(or (member 'sdtlinks-endpoint-with-links-face (face-list))
    (progn
      (make-face 'sdtlinks-endpoint-with-links-face)
      (make-face-bold 'sdtlinks-endpoint-with-links-face nil t)
      (set-face-underline-p 'sdtlinks-endpoint-with-links-face t)
      (set-face-foreground 'sdtlinks-endpoint-with-links-face "blue")))

;;;; MINOR MODE "SDTLINKS-MODE"

;;; Show "SDTlinks" on the mode-line
(or (assq 'sdtlinks-mode minor-mode-alist)
    (setq minor-mode-alist
          (cons '(sdtlinks-mode " SDTlinks") minor-mode-alist)))

;;; Key bindings
(or (assq 'sdtlinks-mode minor-mode-map-alist)
    (setq minor-mode-map-alist
	  (cons (cons 'sdtlinks-mode sdtlinks-mode-map) minor-mode-map-alist)))

(defun sdtlinks-mode (&optional arg)
  "SDTlinks-mode supports link handling in the SDT environment.
ARG is the minor mode toggle."
  (interactive "P")
  (let ((old-mode sdtlinks-mode))
    (setq sdtlinks-mode
      (if (null arg)
	  (not sdtlinks-mode)
	  (> (prefix-numeric-value arg) 0)))
    (if (not (equal old-mode sdtlinks-mode))
        (if sdtlinks-mode
            (progn
              (sdtlinks-mode-init)
              (run-hooks 'sdtlinks-mode-hook))
            (sdtlinks-mode-cleanup)))))

(defun sdtlinks-mode-init ()
  (sdtlinks-remove-all-endpoints)
  (setq sdtlinks-anchor-counter 0)
  (if (null sdtemacs-process)
      (sdtemacs-connect))
  (sdtemacs-load-notify)
  (sdtlinks-file-to-buffer-format))

(defun sdtlinks-mode-cleanup ()
  (sdtlinks-buffer-to-file-format)
  (setq sdtlinks-anchor-counter 0))

;;; Should be able to handle at least 1000 endpoints
(defvar sdtemacs-max-no-of-endpoints 1000)
(if (< max-lisp-eval-depth (* 5 sdtemacs-max-no-of-endpoints))
    (setq max-lisp-eval-depth (* 5 sdtemacs-max-no-of-endpoints)))
(if (< max-specpdl-size (* 15 sdtemacs-max-no-of-endpoints))
    (setq max-specpdl-size (* 15 sdtemacs-max-no-of-endpoints)))

(add-hook 'after-insert-file-functions 'sdtlinks-after-insert-file)
(add-hook 'write-region-annotate-functions 'sdtlinks-write-region-annotate)
(add-hook 'before-revert-hook 'sdtlinks-before-revert)
(add-hook 'after-revert-hook 'sdtlinks-after-revert)

;;;; TRANSLATE DATA FROM/TO SDTEMACS

;;; Endpoints

(defun sdtlinks-make-endpoint-alist (data)
;;; In: an endpoint (string):
;; "(<format>(String), <filename>(QuotedString) | -b <bufId>(integer) [, <anchor>(QuotedString?) ])
;;  <name>(QuotedString) <type>(integer)"
;; Returns a list with an association list:
;; (format filename|buffer-id [anchor] name type)
;; and rest-of-data(string)
  (let (endpoint-format
        reference
        filename-exist)

    (if (string-match "," data) (setq data (replace-match " " nil nil data)))
    (if (string-match "," data) (setq data (replace-match " " nil nil data)))
    (setq endpoint-format (sdtemacs-make-list 3 data))
    (setq reference (nth 0 endpoint-format))
    (setq filename-exist (not (eq (nth 1 reference) '-b)))
    (list (delete nil (list (cons 'format (nth 0 reference))
                            (if filename-exist
                                (cons 'filename (sdtemacs-make-string (nth 1 reference)))
                                (cons 'buffer-id (nth 2 reference)))
                            (if filename-exist
                                (if (nth 2 reference)
                                    (cons 'anchor (nth 2 reference)))
                                (if (nth 3 reference)
                                    (cons 'anchor (nth 3 reference))))
                            (cons 'name (sdtemacs-make-string (nth 1 endpoint-format)))
                            (cons 'type (nth 2 endpoint-format))))
          (nth 3 endpoint-format))))

(defun sdtlinks-make-endpoint-string (endpoint)
;;; Input: an endpoint (alist):
;; (format filename|buffer-id [anchor] name type) or (anchor cardinality overlay)
;; Returns a string:
;; "(<format>, <filename> | -b <bufId> [, <anchor> ]) <name> <type>"
    (concat "("
            (symbol-name (sdtlinks-get-endpoint-format endpoint))
            ", "
            (or (sdtlinks-get-endpoint-filename endpoint)
                (concat "-b "
                        (number-to-string (sdtlinks-get-endpoint-buffer-id endpoint))))
            (if (sdtlinks-get-endpoint-anchor endpoint)
                (concat ", "
                        (number-to-string (sdtlinks-get-endpoint-anchor endpoint)))
                "")
            ") "
            (sdtemacs-quote-string (sdtlinks-get-endpoint-short-name endpoint))
            " "
            (number-to-string (sdtlinks-get-endpoint-type endpoint))))

;;; Links

(defun sdtlinks-make-link-alist (data)
;;; Link (string):
;; "(<from-endpoint> <to-endpoint> <name> <comment>)"
;; Returns a list with an association list:
;; (from-endpoint to-endpoint name comment)
;; and rest-of-data(string)
  (let (params
        from-endpoint
        to-endpoint
        name
        comment)

    (if (string-match "(" data) (setq data (replace-match "" nil nil data)))
    (setq params (sdtlinks-make-endpoint-alist data))
    (setq from-endpoint (nth 0 params))
    (setq data (nth 1 params))
    (if (string-match ")" data) (setq data (replace-match "" nil nil data)))
    (if (string-match "(" data) (setq data (replace-match "" nil nil data)))
    (setq params (sdtlinks-make-endpoint-alist data))
    (setq to-endpoint (nth 0 params))
    (setq data (nth 1 params))
    (if (string-match ")" data) (setq data (replace-match "" nil nil data)))
    (setq params (sdtemacs-make-list 2 data))
    (setq name (nth 0 params))
    (setq comment (nth 1 params))
    (list (list (cons 'from-endpoint from-endpoint)
                (cons 'to-endpoint to-endpoint)
                (cons 'name name)
                (cons 'comment comment))
          (nth 2 params))))
 
;;;; SDTEMACS-INTERFACE

(add-hook 'sdtemacs-message-hooks 'sdtlinks-message-handler)
(add-hook 'sdtemacs-new-buffer-hooks 'sdtlinks-new-buffer)

(defun sdtlinks-message-handler (message pid data)
  (cond ((eq message 'SELINKCARDINALITYNOTIFY) (sdtlinks-handle-selinkcardinalitynotify pid data))
        ((eq message 'SEGETLINKCARDINALITYREPLY) (sdtlinks-handle-segetlinkcardinalityreply pid data))
        ((eq message 'SEGETLINKSREPLY) (sdtlinks-handle-segetlinksreply pid data))
        ((eq message 'SESHOWENDPOINTANCHOR) (sdtlinks-handle-seshowendpointanchor pid data))
        ((eq message 'SESHOWENDPOINTREPLY) (sdtlinks-handle-seshowendpointreply pid data))))

(defun sdtlinks-set-buffer-modified ()
  (if (not (buffer-modified-p))
    (progn
      (set-buffer-modified-p t)
      (sdtemacs-dirty-notify))))

(defun sdtlinks-handle-seshowendpointanchor (pid data)
;;; data = <bufId>(integer) <anchor>(QuotedString)
  (let* ((params (sdtemacs-make-list 2 data))
         (buffer-id (nth 0 params))
         (anchor (string-to-number (sdtemacs-make-string (nth 1 params))))
         endpoint
         (buffer (sdtemacs-get-buffer buffer-id))
         (status-code 'OK)
         error-message)

    (cond ((null buffer)
           (setq status-code 'ErrorString)
           (setq error-message (concat "Buffer "
                                       (number-to-string buffer-id)
                                       " does not exist.")))
          (t
           (switch-to-buffer buffer)
           (if (not sdtlinks-mode) (sdtlinks-mode t))
           (if anchor (setq endpoint (sdtlinks-get-endpoint-from-anchor anchor)))
           (cond ((and anchor
                       (null endpoint))
                  (setq status-code 'ErrorString)
                  (setq error-message (concat "Endpoint with anchor '"
					      (number-to-string anchor)
                                              "' not found.")))
                 (anchor
                  (goto-char (overlay-start (sdtlinks-get-endpoint-overlay endpoint)))
                  (recenter)
                  (raise-frame (window-frame (get-buffer-window buffer))))
                 (t
                  (goto-char (point-min))
                  (raise-frame (window-frame (get-buffer-window buffer)))))))

    (if (eq status-code 'OK)
        (sdtemacs-send-reply pid
                             'SESHOWENDPOINTANCHORREPLY
                             (list (sdtemacs-status-value status-code)))
        (sdtemacs-send-reply pid
                             'SESHOWENDPOINTANCHORREPLY
                             (list (sdtemacs-status-value status-code)
                                   (sdtemacs-quote-string error-message))))))

;;;; ENDPOINTS

(defun sdtlinks-new-overlay (start end)
  (let ((ovl (make-overlay start end)))
    (overlay-put ovl 'face 'sdtlinks-endpoint-face)
    (overlay-put ovl 'modification-hooks
                     (cons 'sdtlinks-endpoint-text-changed
                           (overlay-get ovl 'modification-hooks)))
    (overlay-put ovl 'insert-in-front-hooks
                     (cons 'sdtlinks-endpoint-text-changed
                           (overlay-get ovl 'insert-in-front-hooks)))
    (overlay-put ovl 'insert-behind-hooks
                     (cons 'sdtlinks-endpoint-text-insert-behind
                           (overlay-get ovl 'insert-behind-hooks)))
    ovl))

(defun sdtlinks-new-anchor ()
  (setq sdtlinks-anchor-counter (1+ sdtlinks-anchor-counter)))

(defun sdtlinks-anchor-found (anchor)
  (if (> anchor sdtlinks-anchor-counter)
      (setq sdtlinks-anchor-counter anchor)))

(defun sdtlinks-new-endpoint (anchor start end)
  (list (cons 'anchor anchor)
        (cons 'overlay (sdtlinks-new-overlay start end))
        (cons 'cardinality 0)))

(defun sdtlinks-internal-endpoint-p (endpoint)
  (assq 'overlay endpoint))

(defun sdtlinks-get-endpoint-format (endpoint)
  (if (sdtlinks-internal-endpoint-p endpoint)
      'TEXT
      (cdr (assq 'format endpoint))))

(defun sdtlinks-get-endpoint-filename (endpoint)
  (if (sdtlinks-internal-endpoint-p endpoint)
      (if (and buffer-file-name
               (file-exists-p buffer-file-name))
          buffer-file-name)
      (cdr (assq 'filename endpoint))))

(defun sdtlinks-get-endpoint-buffer-id (endpoint)
  (if (sdtlinks-internal-endpoint-p endpoint)
      (sdtemacs-get-buffer-id (current-buffer))
      (cdr (assq 'buffer-id endpoint))))

(defun sdtlinks-get-endpoint-type (endpoint)
  (if (sdtlinks-internal-endpoint-p endpoint)
      0
      (cdr (assq 'type endpoint))))

(defun sdtlinks-get-endpoint-anchor (endpoint)
  (cdr (assq 'anchor endpoint)))

(defun sdtlinks-get-endpoint-overlay (endpoint)
  (cdr (assq 'overlay endpoint)))

(defun sdtlinks-get-endpoint-cardinality (endpoint)
  (cdr (assq 'cardinality endpoint)))
  
(defun sdtlinks-get-endpoint-name (endpoint)
  (if (sdtlinks-internal-endpoint-p endpoint)
      (buffer-substring (overlay-start (sdtlinks-get-endpoint-overlay endpoint))
                        (overlay-end (sdtlinks-get-endpoint-overlay endpoint)))
      (cdr (assq 'name endpoint))))

(defun sdtlinks-get-endpoint-short-name (endpoint)
  (let ((name (sdtlinks-get-endpoint-name endpoint)))
    (if (<= (length name) 25)
        name
        (substring name 0 25))))

(defun sdtlinks-put-endpoint-cardinality (endpoint cardinality)
  (setcdr (assq 'cardinality endpoint) cardinality)
  (if (zerop cardinality)
      (overlay-put (sdtlinks-get-endpoint-overlay endpoint) 'face 'sdtlinks-endpoint-face)
      (overlay-put (sdtlinks-get-endpoint-overlay endpoint) 'face 'sdtlinks-endpoint-with-links-face)))

(defun sdtlinks-eq-endpoints (endpoint-1 endpoint-2)
  (and (eq (sdtlinks-get-endpoint-format endpoint-1)
           (sdtlinks-get-endpoint-format endpoint-2))
       (if (sdtlinks-get-endpoint-filename endpoint-1)
           (string-equal (sdtlinks-get-endpoint-filename endpoint-1)
                         (sdtlinks-get-endpoint-filename endpoint-2))
           (eq (sdtlinks-get-endpoint-buffer-id endpoint-1)
               (sdtlinks-get-endpoint-buffer-id endpoint-2)))
       (eq (sdtlinks-get-endpoint-anchor endpoint-1)
           (sdtlinks-get-endpoint-anchor endpoint-2))))

(defun sdtlinks-endpoints-in-region-p (region-start region-end)
  (sdtlinks-endpoints-in-region-p-hlp region-start (1- region-end) sdtlinks-endpoints))

(defun sdtlinks-endpoints-in-region-p-hlp (region-start region-end endpoints)
  (let (ovl-start
        ovl-end)

    (cond ((null endpoints) nil)
          ((and (setq ovl-start (overlay-start (sdtlinks-get-endpoint-overlay (car endpoints))))
                (setq ovl-end (1- (overlay-end (sdtlinks-get-endpoint-overlay (car endpoints)))))
	        (or (and (>= ovl-start region-start)
                         (<= ovl-start region-end))
                    (and (>= ovl-end region-start)
                         (<= ovl-end region-end))
                    (and (<= ovl-start region-start)
                         (>= ovl-end region-end))))
	   t)
          ((< region-end ovl-end) nil)
	  (t (sdtlinks-endpoints-in-region-p-hlp region-start region-end (cdr endpoints))))))

(defun sdtlinks-get-endpoint-from-pos (point-pos)
  (sdtlinks-get-endpoint-from-pos-hlp point-pos sdtlinks-endpoints))

(defun sdtlinks-get-endpoint-from-pos-hlp (point-pos endpoints)
  (cond ((null endpoints) nil)
	((and (>= point-pos
                  (overlay-start (sdtlinks-get-endpoint-overlay (car endpoints))))
	      (<= point-pos
                  (1- (overlay-end (sdtlinks-get-endpoint-overlay (car endpoints))))))
	 (car endpoints))
        ((< point-pos
            (1- (overlay-end (sdtlinks-get-endpoint-overlay (car endpoints))))) nil)
	(t (sdtlinks-get-endpoint-from-pos-hlp point-pos (cdr endpoints)))))

(defun sdtlinks-get-endpoint-from-anchor (anchor)
  (sdtlinks-get-endpoint-from-anchor-hlp anchor sdtlinks-endpoints))

(defun sdtlinks-get-endpoint-from-anchor-hlp (anchor endpoints)
  (cond ((null endpoints) nil)
	((eq (sdtlinks-get-endpoint-anchor (car endpoints)) anchor) (car endpoints))
	(t (sdtlinks-get-endpoint-from-anchor-hlp anchor (cdr endpoints)))))

(defun sdtlinks-get-endpoint-from-overlay (ovl)
  (sdtlinks-get-endpoint-from-overlay-hlp ovl sdtlinks-endpoints))

(defun sdtlinks-get-endpoint-from-overlay-hlp (ovl endpoints)
  (cond ((null endpoints) nil)
	((eq (sdtlinks-get-endpoint-overlay (car endpoints)) ovl) (car endpoints))
	(t (sdtlinks-get-endpoint-from-overlay-hlp ovl (cdr endpoints)))))

(defun sdtlinks-add-endpoint (new-endpoint insert)
  (if insert
      (setq sdtlinks-endpoints (sdtlinks-insert-endpoint new-endpoint sdtlinks-endpoints))
      (setq sdtlinks-endpoints (nconc sdtlinks-endpoints (list new-endpoint)))))

(defun sdtlinks-insert-endpoint (new-endpoint endpoints)
  (cond ((null endpoints) (list new-endpoint))
	((< (overlay-start (sdtlinks-get-endpoint-overlay new-endpoint))
	    (overlay-start (sdtlinks-get-endpoint-overlay (car endpoints))))
	 (cons new-endpoint endpoints))
	(t (cons (car endpoints) (sdtlinks-insert-endpoint new-endpoint (cdr endpoints))))))

(defun sdtlinks-remove-endpoint (endpoint)
  (setq sdtlinks-endpoints
        (sdtlinks-remove-endpoint-hlp (sdtlinks-get-endpoint-anchor endpoint) sdtlinks-endpoints)))

(defun sdtlinks-remove-endpoint-hlp (anchor endpoints)
  (cond ((null endpoints) nil)
	((eq anchor (sdtlinks-get-endpoint-anchor (car endpoints)))
         (delete-overlay (sdtlinks-get-endpoint-overlay (car endpoints)))
         (cdr endpoints))
	(t (cons (car endpoints)
                 (sdtlinks-remove-endpoint-hlp anchor (cdr endpoints))))))

(defun sdtlinks-remove-all-endpoints ()
  (cond ((null sdtlinks-endpoints) nil)
        (t (sdtlinks-remove-endpoint (car sdtlinks-endpoints))
           (sdtlinks-remove-all-endpoints))))

(defun sdtlinks-endpoint-text-changed (ovl after-change start end &optional text-len-bc)
; The names in the endpoints are the ones _after_ the change.
; Incorrect, but it works.
  (let (endpoint)

    (cond (sdtlinks-reverting nil)
          ((null (overlay-buffer ovl)) nil)
          (after-change
           (setq endpoint (sdtlinks-get-endpoint-from-overlay ovl))
           (if (and (eq start end)
                    (eq (overlay-start ovl) (overlay-end ovl)))
             ; Deletion
             (sdtlinks-delete-and-notify-endpoint endpoint)
             ; Modification
             (sdtemacs-broadcast 'SEMODIFYENDPOINTNOTIFY
                                 (list (sdtemacs-quote-string (sdtlinks-make-endpoint-string endpoint))
                                       (sdtemacs-quote-string (sdtlinks-get-endpoint-short-name endpoint))
                                       0)))))))

(defun sdtlinks-endpoint-text-insert-behind (ovl after-change start end &optional text-len-bc)
  (let ((endpoint (sdtlinks-get-endpoint-from-overlay ovl)))

    (cond ((not after-change)
            (setq sdtlinks-endpoint-string-bc (sdtlinks-make-endpoint-string endpoint)))
           (after-change
            (move-overlay ovl (overlay-start ovl) end)
            (sdtemacs-broadcast 'SEMODIFYENDPOINTNOTIFY
                                (list (sdtemacs-quote-string sdtlinks-endpoint-string-bc)
                                      (sdtemacs-quote-string (sdtlinks-get-endpoint-short-name endpoint))
                                      0))))))

(defun sdtlinks-create-and-notify-endpoint (start end insert)
  (let ((new-endpoint (sdtlinks-new-endpoint (sdtlinks-new-anchor) start end)))
    (sdtlinks-add-endpoint new-endpoint insert)
    (sdtemacs-broadcast 'SECREATEENDPOINTNOTIFY
                        (list (sdtemacs-quote-string (sdtlinks-make-endpoint-string new-endpoint))))))

(defun sdtlinks-delete-and-notify-endpoint (endpoint)
  (sdtemacs-broadcast 'SEDELETEENDPOINTNOTIFY
                      (list (sdtemacs-quote-string (sdtlinks-make-endpoint-string endpoint))))
  (sdtlinks-remove-endpoint endpoint))

(defun sdtlinks-handle-seshowendpointreply (pid data)
;;; data = <status-code>(integer) [<error-string>(QuotedString)|<error-code>(integer)]
  (let* ((params (sdtemacs-make-list 2 data))
         (status-code (sdtemacs-status-code (nth 0 params)))
         (error (sdtemacs-make-string (nth 1 params))))

    (if (not (eq status-code 'OK))
        (sdtemacs-print-reply-error "Could not show endpoint." status-code error))))

(defun sdtlinks-create-endpoint (start end)
  "Create a new endpoint for SDT-links.
START is the position of the first character of the endpoint text.
END is the position of the last character of the endpoint text."
  (interactive "r")

  (cond ((not sdtlinks-mode)
	 (error "Not in SDTlinks-mode"))
        ((eq start end)
         (error "An endpoint must consist of at least one character"))
        ((sdtlinks-endpoints-in-region-p start end)
         (error "Overlapping endpoints are not allowed"))
        (t
         (sdtlinks-create-and-notify-endpoint start end t)
         (sdtlinks-set-buffer-modified))))

(defun sdtlinks-delete-endpoint (point-pos)
  "Delete an endpoint for SDT-links.
POINT-POS is the position of an arbitrary character in the endpoint text."

  (interactive "d")
  (let ((endpoint (sdtlinks-get-endpoint-from-pos point-pos)))

    (cond ((not sdtlinks-mode)
	   (error "Not in SDTlinks-mode"))
	  ((null endpoint)
	   (error "No endpoint selected"))
	  (t
           (sdtlinks-delete-and-notify-endpoint endpoint)
	   (sdtlinks-set-buffer-modified)))))
           
(defun sdtlinks-show-endpoint-in-link-manager (point-pos)
  "Show an endpoint in the Link Manager.
POINT-POS is the position of an arbitrary character in the endpoint text."

  (interactive "d")
  (let ((endpoint (sdtlinks-get-endpoint-from-pos point-pos)))

    (cond ((not sdtlinks-mode)
	   (error "Not in SDTlinks-mode"))
	  ((null endpoint)
	   (error "No endpoint selected"))
	  (t
           (sdtemacs-send-to-tool 'SET_ORGANIZER
                                  'SESHOWENDPOINT
                                  (list (sdtemacs-quote-string (sdtlinks-make-endpoint-string endpoint))
                                        (sdtemacs-sdt-boolean nil)))))))

;;;; LINKS

(defun sdtlinks-get-link-from-endpoint (link)
  (cdr (assq 'from-endpoint link)))

(defun sdtlinks-get-link-to-endpoint (link)
  (cdr (assq 'to-endpoint link)))

(defun sdtlinks-get-link-name (link)
  (cdr (assq 'name link)))

(defun sdtlinks-get-link-comment (link)
  (cdr (assq 'comment link)))

(defun sdtlinks-get-other-endpoint-of-link (endpoint link)
  (if (sdtlinks-eq-endpoints endpoint (sdtlinks-get-link-from-endpoint link))
      (sdtlinks-get-link-to-endpoint link)
      (sdtlinks-get-link-from-endpoint link)))

(defun sdtlinks-get-link-direction (endpoint link)
  (if (sdtlinks-eq-endpoints endpoint (sdtlinks-get-link-from-endpoint link))
      'out
      'in))

(defun sdtlinks-choose-link-dialog (endpoint list-of-links)
  (let ((position (cons '(0 0) (list (get-buffer-window (current-buffer)))))
        (idx 0)
        link
        other-endpoint
        menu
        menu-text)

    (while (< idx (length list-of-links))
      (setq link (nth idx list-of-links))
      (setq other-endpoint (sdtlinks-get-other-endpoint-of-link endpoint link))
      (setq menu-text (concat (sdtlinks-get-link-name link)
                              " ("
                              (symbol-name (sdtlinks-get-link-direction endpoint link))
                              "), "
                              (sdtlinks-get-endpoint-name other-endpoint)
                              " ("
                              (symbol-name (sdtlinks-get-endpoint-format other-endpoint))
                              "), "
                              (or (sdtlinks-get-endpoint-filename other-endpoint)
                                  "Unconnected")))
      (setq menu (cons (cons menu-text idx) menu))
      (setq idx (1+ idx)))
    (setq menu (list "Choose link to follow" (cons "Dummy" menu)))
    (x-popup-menu position menu)))

(defun sdtlinks-handle-selinkcardinalitynotify (pid data)
;;; data = <endpoint>(QuotedString) <number-of-links>(integer)
  (let* ((data2 (sdtemacs-make-list 1 data))
	 (params (sdtlinks-make-endpoint-alist (nth 0 data2)))
         (endpoint-ref (nth 0 params))
         (number-of-links (string-to-number (nth 1 data2)))
         (anchor (sdtlinks-get-endpoint-anchor endpoint-ref))
         (buffer-id (sdtlinks-get-endpoint-buffer-id endpoint-ref))
         (filename (sdtlinks-get-endpoint-filename endpoint-ref))
         buffer
         endpoint)

    ; Find the buffer
    (cond ((null anchor) nil)
          (buffer-id (setq buffer (sdtemacs-get-buffer buffer-id)))
          (t (setq buffer (sdtemacs-get-buffer-from-filename filename))))

    ; Find the endpoint and change the cardinality
    (if buffer
        (save-excursion
          (set-buffer buffer)
          (if (and sdtlinks-mode
                   (setq endpoint (sdtlinks-get-endpoint-from-anchor anchor)))
              (sdtlinks-put-endpoint-cardinality endpoint number-of-links))))))

(defun sdtlinks-handle-segetlinksreply (pid data)
;;; data = <status-code>(integer)
;;        (<number-of-links>(integer) <list-of-links>(QuotedStrings)) |
;;        ([<error-string>(QuotedString)|<error-code(integer)>])
  (let* ((params (sdtemacs-make-list 2 data))
         (status-code (sdtemacs-status-code (nth 0 params)))
         number-of-links
         list-of-links
         error
         (link-counter 0)
         links)

    ; Extract number-of-links, list-of-links(string) (or error) from data
    (cond ((eq status-code 'OK)
           (setq number-of-links (nth 1 params))
           (setq list-of-links (nth 2 params)))
          (t
           (setq error (sdtemacs-make-string (nth 1 params)))))

    (setq sdtlinks-reply-info (list (cons 'reply-message 'SEGETLINKSREPLY)
                                    (cons 'status-code status-code)))

    (cond ((not (eq status-code 'OK))
           (sdtemacs-print-reply-error "Could not follow link." status-code error))
          (t
           (while (< link-counter number-of-links)
	      (setq list-of-links (sdtemacs-make-list 1 list-of-links))
              (setq links (cons (nth 0 (sdtlinks-make-link-alist (nth 0 list-of-links))) links))
              (setq list-of-links (nth 1 list-of-links))
              (setq link-counter (1+ link-counter)))
           (setq sdtlinks-reply-info (append (list (cons 'number-of-links number-of-links)
                                                   (cons 'list-of-links links))
                                             sdtlinks-reply-info))))))

(defun sdtlinks-handle-segetlinkcardinalityreply (pid data)
;;; data = <status-code>(integer)
;;        (<number-of-links>(integer)|[<error-string>(QuotedString)|<error-code>(integer)])
  (let* ((params (sdtemacs-make-list 2 data))
         (status-code (sdtemacs-status-code (nth 0 params)))
         number-of-links
         error)

    ; Extract number-of-links (or error) from data
    (if (eq status-code 'OK)
        (setq number-of-links (nth 1 params))
        (setq error (sdtemacs-make-string (nth 1 params))))

    (setq sdtlinks-reply-info (list (cons 'reply-message 'SEGETLINKCARDINALITYREPLY)
                                    (cons 'status-code status-code)))

    (if (not (eq status-code 'OK))
        (sdtemacs-print-reply-error "Could not get the link cardinality." status-code error)
        (setq sdtlinks-reply-info (append (list (cons 'number-of-links number-of-links))
                                          sdtlinks-reply-info)))))

(defun sdtlinks-follow-link (point-pos)
  "Follow an SDT-link from an endpoint.
POINT-POS is the position of an arbitrary character in the endpoint text."

  (interactive "d")

  (let ((endpoint (sdtlinks-get-endpoint-from-pos point-pos))
        other-endpoint
        link
        link-idx)

    (cond ((not sdtlinks-mode)
	   (error "Not in SDTlinks-mode"))
	  ((null endpoint)
	   (error "No endpoint selected"))
          ((zerop (sdtlinks-get-endpoint-cardinality endpoint))
	   (error "No links defined for this endpoint"))
	  (t
           (sdtemacs-send-to-tool 'SET_ORGANIZER
                                  'SEGETLINKS
                                  (list (sdtemacs-quote-string (sdtlinks-make-endpoint-string endpoint))))
           (cond ((not (eq (cdr (assq 'status-code sdtlinks-reply-info)) 'OK))
                  nil)
                 ((eq (cdr (assq 'number-of-links sdtlinks-reply-info)) 1)
                  (setq link-idx 0))
                 (t
                  (setq link-idx (sdtlinks-choose-link-dialog endpoint (cdr (assq 'list-of-links sdtlinks-reply-info))))))
           (if link-idx
             (progn
               (setq link (nth link-idx (cdr (assq 'list-of-links sdtlinks-reply-info))))
               (setq other-endpoint (sdtlinks-get-other-endpoint-of-link endpoint link))
               (sdtemacs-send-to-tool 'SET_ORGANIZER
                                      'SESHOWENDPOINT
                                      (list (sdtemacs-quote-string (sdtlinks-make-endpoint-string other-endpoint))
                                            (sdtemacs-sdt-boolean t)))))))))

;;;; BUFFER AND FILE FORMATS

(defun sdtlinks-new-buffer ()
  (if sdtemacs-process
      (sdtlinks-mode t)))

(defun sdtlinks-write-region-annotate (region-start region-end)
  (let ((endpoints sdtlinks-endpoints)
        annotations
        start
        start-annotation
        end
        end-annotation)

  (if sdtlinks-mode
    (progn

      ; Skip the endpoints in front of the region
      (while (and endpoints
                  (< (overlay-start (sdtlinks-get-endpoint-overlay (car endpoints)))
                     region-start))
        (setq endpoints (cdr endpoints)))

      ; Add annotations for endpoints within the region
      (while (and endpoints
                  (setq start (overlay-start (sdtlinks-get-endpoint-overlay (car endpoints))))
  	          (setq end (overlay-end (sdtlinks-get-endpoint-overlay (car endpoints))))
                  (<= end region-end))
        (setq start-annotation
              (cons start
                    (sdtlinks-endpoint-begin-mark (sdtlinks-get-endpoint-anchor (car endpoints)))))
        ; If two endpoints with no chars in between
        (if (assq start annotations)
           (progn
              (setq annotations (delete (assq start annotations) annotations))
              (setcdr start-annotation (concat sdtlinks-endpoint-end-mark
                                               (cdr start-annotation)))))
        (setq end-annotation (cons end sdtlinks-endpoint-end-mark))
        (setq annotations (append annotations (list start-annotation end-annotation)))
        (setq endpoints (cdr endpoints)))

      annotations))))

(defun sdtlinks-after-insert-file (len)
; Returns the updated length
  (let* ((start (point))
         (end (+ start len)))

    (cond (sdtlinks-reverting
           len)
          ;Insert a copy of a file
          ((and (eq (buffer-size) len)
                (null buffer-file-name))
           (if (and (not sdtlinks-mode)
                    sdtemacs-process)
               (progn
                 (setq sdtlinks-mode t)
                 (sdtemacs-load-notify)))
           (sdtlinks-add-to-buffer start len))
          ;Insert file
          ((> (buffer-size) len)
           (if sdtlinks-mode
             (if (and (sdtlinks-endpoints-in-region-p start (1+ start))
                      (save-excursion
                        (re-search-forward sdtlinks-endpoint-begin-mark-regexp end t)))
               (progn
                 (delete-region start end)
      	         (error "The file contains endpoints. Overlapping endpoints are not allowed"))
               (sdtlinks-add-to-buffer start len))
             (sdtlinks-remove-endpoint-markers start len)))
          ;Load file
          (t
           (buffer-size)))))

(defun sdtlinks-add-to-buffer (point-pos len)
; Returns the updated length
  (let (start
        end)

    (save-excursion
      (while (re-search-forward sdtlinks-endpoint-begin-mark-regexp (+ point-pos len) t)
        (buffer-disable-undo)
	(setq start (match-beginning 0))
	(setq len (- len (length (match-string 0))))
        (replace-match "")
	(search-forward sdtlinks-endpoint-end-mark (+ point-pos len) t)
	(setq end (match-beginning 0))
	(setq len (- len (length (match-string 0))))
        (replace-match "")
        (sdtlinks-create-and-notify-endpoint start end t)
        (buffer-enable-undo)))
    len))

(defun sdtlinks-remove-endpoint-markers (point-pos len)
; Returns the updated length
  (let ((search-criteria (concat sdtlinks-endpoint-begin-mark-regexp
                                 "\\|"
                                 sdtlinks-endpoint-end-mark)))

    (save-excursion
      (while (re-search-forward search-criteria (+ point-pos len) t)
        (buffer-disable-undo)
	(setq len (- len (length (match-string 0))))
        (replace-match "")
        (buffer-enable-undo)))
    len))

(defun sdtlinks-before-revert ()
  (setq sdtemacs-inhibit-dirty-flag t)
  (setq sdtlinks-reverting t))

(defun sdtlinks-after-revert ()
  (if sdtlinks-mode (sdtlinks-mode-init))
  (setq sdtemacs-inhibit-dirty-flag nil)
  (setq sdtlinks-reverting nil))

(defun sdtlinks-buffer-to-file-format ()
  (let ((modified (buffer-modified-p))
        (endpoints sdtlinks-endpoints)
        endpoints-info)

    (while endpoints
      (setq endpoints-info
            (cons (list (cons 'start (overlay-start (sdtlinks-get-endpoint-overlay (car endpoints))))
                        (cons 'end (overlay-end (sdtlinks-get-endpoint-overlay (car endpoints))))
                        (cons 'anchor (sdtlinks-get-endpoint-anchor (car endpoints))))
                  endpoints-info))
      (setq endpoints (cdr endpoints)))
    (sdtlinks-remove-all-endpoints)
    (save-excursion
      (buffer-disable-undo)
      (setq sdtemacs-inhibit-dirty-flag t)
      (while endpoints-info
        (goto-char (cdr (assq 'end (car endpoints-info))))
        (insert sdtlinks-endpoint-end-mark)
        (goto-char (cdr (assq 'start (car endpoints-info))))
        (insert (sdtlinks-endpoint-begin-mark (cdr (assq 'anchor (car endpoints-info)))))
        (setq endpoints-info (cdr endpoints-info)))
      (set-buffer-modified-p modified)
      (setq sdtemacs-inhibit-dirty-flag nil)
      (buffer-enable-undo))))

(defun sdtlinks-file-to-buffer-format ()
; If an end-mark is faulty: the algorithm chooses the next end-mark...
; What if we find more than one endpoint with the same anchor?
  (let (start
        end
        anchor
        endpoint
        (modified (buffer-modified-p)))

      (save-excursion
        (buffer-disable-undo)
        (setq sdtemacs-inhibit-dirty-flag t)
        (goto-char (point-min))
        (while (re-search-forward sdtlinks-endpoint-begin-mark-regexp nil t)
          (setq anchor (string-to-number (match-string 1)))
	  (setq start (match-beginning 0))
          (replace-match "")
	  (search-forward sdtlinks-endpoint-end-mark nil t)
          (replace-match "")
	  (setq end (point))
          (setq endpoint (sdtlinks-new-endpoint anchor start end))
          (sdtemacs-send-to-tool 'SET_ORGANIZER
                                 'SEGETLINKCARDINALITY
                                 (list (sdtemacs-quote-string (sdtlinks-make-endpoint-string endpoint))))
  	  (if (eq (cdr (assq 'status-code sdtlinks-reply-info)) 'OK)
              (sdtlinks-put-endpoint-cardinality endpoint
                                                 (cdr (assq 'number-of-links sdtlinks-reply-info))))
          (sdtlinks-add-endpoint endpoint nil)
          (sdtlinks-anchor-found anchor))
        (set-buffer-modified-p modified)
        (setq sdtemacs-inhibit-dirty-flag nil)
        (buffer-enable-undo))))
  
(provide 'sdtlinks)
;;; sdtlinks ends here