;;;;; -*-coding: iso-8859-1;-*- ;;;;; ;;;;; $Id$ ;;;;; Copyright (C) 1991-2002 Lysator Academic Computer Association. ;;;;; ;;;;; This file is part of the LysKOM Emacs LISP client. ;;;;; ;;;;; LysKOM 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. ;;;;; ;;;;; LysKOM 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 LysKOM; see the file COPYING. If not, write to ;;;;; Lysator, c/o ISY, Linkoping University, S-581 83 Linkoping, SWEDEN, ;;;;; or the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, ;;;;; MA 02139, USA. ;;;;; ;;;;; Please mail bug reports to bug-lyskom@lysator.liu.se. ;;;;; ;;;; ================================================================ ;;;; ================================================================ ;;;; ;;;; File: completing-read.el ;;;; Author: David Byers ;;;; ;;;; This file implements functions for reading a conference name ;;;; or a person name with completion and other help. ;;;; (setq lyskom-clientversion-long (concat lyskom-clientversion-long "$Id$\n")) (defvar lyskom-name-hist nil) ;;; ============================================================ ;;; ;;; Name lookup caches ;;; (defvar lyskom-completing-who-info-cache nil "Temporary cache of who-info data") (defvar lyskom-completing-lookup-name-cache nil "Temporary cache of server queries") (defvar lyskom-completing-use-dynamic-info nil) (defun lyskom-completing-clear-cache () (setq lyskom-completing-who-info-cache nil) (setq lyskom-completing-lookup-name-cache nil)) (defun lyskom-completing-who-is-on () "Get information about who is on, first checking the cache. Returns what \(blocking-do 'who-is-on\) would, but as a list, not a vector" (if lyskom-completing-who-info-cache lyskom-completing-who-info-cache (setq lyskom-completing-who-info-cache (listify-vector (if (lyskom-have-feature dynamic-session-info) (blocking-do 'who-is-on-dynamic t t 0) (blocking-do 'who-is-on)))))) (defun lyskom-completing-cache-completion (string data) (let* ((downs (lyskom-unicase string)) (tmp (assoc downs lyskom-completing-lookup-name-cache))) (if (null tmp) (setq lyskom-completing-lookup-name-cache (cons (cons downs data) lyskom-completing-lookup-name-cache))) string)) (defun lyskom-completing-lookup-z-name (string want-conf want-pers) "Look up STRING as a name. Same as \(blocking-do 'lookup-z-name ...\) but first checks a cache." (if (and (eq 0 want-conf) (eq 0 want-pers)) nil (let* ((downs (lyskom-unicase string)) (tmp (assoc downs lyskom-completing-lookup-name-cache))) (if tmp (cdr tmp) (progn (setq tmp (blocking-do 'lookup-z-name string want-pers want-conf)) (setq lyskom-completing-lookup-name-cache (cons (cons downs tmp) lyskom-completing-lookup-name-cache)) tmp))))) ;;; ============================================================ ;;; ;;; Keymaps ;;; (defvar lyskom-minibuffer-local-completion-map (let ((map (copy-keymap minibuffer-local-completion-map))) (define-key map " " nil) map) "Keymap used for reading LysKOM names.") (defvar lyskom-minibuffer-local-must-match-map (let ((map (copy-keymap minibuffer-local-must-match-map))) (lyskom-xemacs-or-gnu (set-keymap-parent map lyskom-minibuffer-local-completion-map) (define-key map " " nil)) map) "Keymap used for reading LysKOM names.") (defsubst lyskom-completing-match-string-regexp (string) (concat "^" (replace-in-string (regexp-quote (lyskom-unicase (lyskom-completing-strip-name string))) "\\s-+" "\\\\S-*\\\\s-+") "\\s-*")) (defsubst lyskom-completing-match-string (string name) "Return non-nil if STRING matches NAME using LysKOM completion rules." (string-match (lyskom-completing-match-string-regexp string) (lyskom-completing-strip-name (lyskom-unicase name)))) (defun lyskom-read-conf-no (prompt type &optional empty initial mustmatch) "Read a conference name from the minibuffer with completion and return its number or zero if nothing was matched. See lyskom-read-conf for a description of the parameters." (let ((conf-z-info (lyskom-read-conf prompt type empty initial mustmatch))) (cond ((null conf-z-info) 0) ((stringp conf-z-info) 0) ((lyskom-conf-stat-p conf-z-info) (conf-stat->conf-no conf-z-info)) ((lyskom-uconf-stat-p conf-z-info) (uconf-stat->conf-no conf-z-info)) (t (conf-z-info->conf-no conf-z-info))))) (defun lyskom-read-conf-stat (prompt type &optional empty initial mustmatch) "Read a conference name from the minibuffer with completion and return its conf-stat or nil if nothing was matched. See lyskom-read-conf for a description of the parameters." (let ((conf-z-info (lyskom-read-conf prompt type empty initial mustmatch))) (cond ((null conf-z-info) nil) ((stringp conf-z-info) nil) ((lyskom-conf-stat-p conf-z-info) conf-z-info) ((lyskom-uconf-stat-p conf-z-info) (blocking-do 'get-conf-stat (uconf-stat->conf-no conf-z-info))) (t (blocking-do 'get-conf-stat (conf-z-info->conf-no conf-z-info)))))) (defun lyskom-read-uconf-stat (prompt type &optional empty initial mustmatch) "Read a conference name from the minibuffer with completion and return its conf-stat or nil if nothing was matched. See lyskom-read-conf for a description of the parameters." (let ((conf-z-info (lyskom-read-conf prompt type empty initial mustmatch))) (cond ((null conf-z-info) nil) ((stringp conf-z-info) nil) ((lyskom-uconf-stat-p conf-z-info) conf-z-info) ((lyskom-conf-stat-p conf-z-info) (blocking-do 'get-uconf-stat (conf-stat->conf-no conf-z-info))) (t (blocking-do 'get-uconf-stat (conf-z-info->conf-no conf-z-info)))))) (defun lyskom-read-conf-name (prompt type &optional empty initial mustmatch) "Read a conference name from the minibuffer with completion and return its name. See lyskom-read-conf for a description of the parameters." (let ((conf-z-info (lyskom-read-conf prompt type empty initial mustmatch))) (cond ((null conf-z-info) "") ((stringp conf-z-info) conf-z-info) ((lyskom-conf-stat-p conf-z-info) (conf-stat->name conf-z-info)) ((lyskom-uconf-stat-p conf-z-info) (uconf-stat->name conf-z-info)) (t (conf-z-info->name conf-z-info))))) ;;; ================================================================ ;;; Code to guess defaults for initial input ;;; (defun lyskom-default-conference-at-point () (let* ((pos (or lyskom-command-point (point))) (type (and pos (get-text-property pos 'lyskom-button-type)))) (and (memq type '(conf pers)) (list (get-text-property pos 'lyskom-button-arg))))) (defun lyskom-default-conference-current () (list lyskom-current-conf)) (defun lyskom-default-conference-self () (list lyskom-pers-no)) (defun lyskom-default-conference-not-self (uc) (not (eq (uconf-stat->conf-no uc) lyskom-pers-no))) (defun lyskom-default-conference-not-current (uc) (not (eq (uconf-stat->conf-no uc) lyskom-current-conf))) (defun lyskom-get-initial-conf-strategy () (or (cdr (assq lyskom-current-command lyskom-default-conference-strategy)) (cdr (assq t lyskom-default-conference-strategy)))) (defun lyskom-read-conf-guess-initial (predicate) "Return a guess for the initial value for lyskom-read-conf." (let* ((strategy (lyskom-get-initial-conf-strategy)) (default (cdr (assq 'default strategy))) (filter (cdr (assq 'filter strategy)))) (uconf-stat->name (car (filter-list (lambda (uconf-stat) (and uconf-stat (not (memq nil (mapcar (lambda (fn) (funcall fn uconf-stat)) filter))) (lyskom-read-conf-internal-verify-type (uconf-stat->conf-no uconf-stat) (uconf-stat->conf-type uconf-stat) predicate nil nil))) (mapcar (lambda (conf-no) (blocking-do 'get-uconf-stat conf-no)) (apply 'append (mapcar 'funcall default)))))))) (defun lyskom-read-conf (prompt type &optional empty initial mustmatch) "Completing read a conference or person from the minibuffer. PROMPT is the prompt type type. TYPE is the type of conferences to return. It is a list of one or more of the following: all Return any conference. conf Return conferences (not letterboxes). pers Return persons (letterboxes). login Return persons who are also logged-in. membership Return only conferences and letterboxes lyskom-pers-no is a member of. none Return names that do not match anything in the database. (restrict c1 c2 ...) Restrict matching to conference numbers c1, c2 etc. The implementation is inefficient for long lists. Optional arguments EMPTY allow nothing to be entered. INITIAL initial contents of the minibuffer. If an integer, use the name of that conference. MUSTMATCH if non-nil, the user must enter a valid name. The return value may be one of A conf-z-info: The conf-z-info associated with the name entered, nil: Nothing was entered, or A string: A name that matched nothing in the database." (lyskom-completing-clear-cache) (setq initial (cond ((integerp initial) (uconf-stat->name (blocking-do 'get-uconf-stat initial))) ((stringp initial) initial) ((lyskom-conf-stat-p initial) (conf-stat->name initial)) ((lyskom-uconf-stat-p initial) (uconf-stat->name initial)) ((lyskom-conf-z-info-p initial) (conf-z-info->name initial)) ((consp initial) initial) ((lyskom-read-conf-guess-initial type)) (t nil))) (let* ((completion-ignore-case t) (minibuffer-local-completion-map lyskom-minibuffer-local-completion-map) (minibuffer-local-must-match-map lyskom-minibuffer-local-must-match-map) (read-string nil) (result nil) (keep-going t)) (while keep-going (setq read-string (lyskom-completing-read (cond ((stringp prompt) prompt) ((symbolp prompt) (lyskom-get-string prompt)) (t (lyskom-get-string 'conf-prompt))) 'lyskom-read-conf-internal type mustmatch (if (listp initial) initial (cons initial 0)) 'lyskom-name-hist)) (setq result (cond ((null read-string) nil) ((string= "" read-string) nil) (t (lyskom-lookup-conf-by-name read-string type)))) (setq keep-going (and (not empty) (null result)))) result)) (defun lyskom-read-conf-get-logins () "Used internally by lyskom-read-conf-internal to get a list of persons who are logged on." (mapcar (if (lyskom-have-feature dynamic-session-info) (function (lambda (el) (dynamic-session-info->person el))) (function (lambda (el) (who-info->pers-no el)))) (lyskom-completing-who-is-on))) (defun lyskom-read-conf-expand-specials (string predicate login-list x-list &optional return-cs) "Used internally by lyskom-read-conf-internal to expand person and conference number specifications to something useful." (cond ((string-match (lyskom-get-string 'person-or-conf-no-regexp) string) (let* ((no (string-to-int (match-string 1 string))) (cs (blocking-do 'get-uconf-stat no))) (if (and cs (lyskom-read-conf-internal-verify-type (uconf-stat->conf-no cs) (uconf-stat->conf-type cs) predicate login-list x-list)) (if return-cs cs (list string))))) ((string-match (lyskom-get-string 'session-no-regexp) string) (let* ((no (string-to-int (match-string 1 string))) (si (blocking-do 'get-session-info no)) (cs (and si (blocking-do 'get-uconf-stat (session-info->pers-no si))))) (if (and cs (lyskom-read-conf-internal-verify-type (uconf-stat->conf-no cs) (uconf-stat->conf-type cs) predicate login-list x-list)) (if return-cs cs (list string))))))) (defun lyskom-read-conf-lookup-specials (string predicate login-list x-list) "Used internally by lyskom-read-conf-internal to look up conf-stats from person and conference number specifications." (let ((cs (lyskom-read-conf-expand-specials string predicate login-list x-list t))) (lyskom-create-conf-z-info (uconf-stat->name cs) (uconf-stat->conf-type cs) (uconf-stat->conf-no cs)))) (defun lyskom-lookup-conf-by-name (string predicate) "Return the conf-z-info associated with STRING that also satisfies PREDICATE or nil if no name matches. See lyskom-read-conf-internal for a documentation of PREDICATE." (if (string= string "") nil (lyskom-read-conf-internal string predicate 'lyskom-lookup))) (defun lyskom-read-conf-internal (string predicate all) "Complete the name STRING according to PREDICATE and ALL. STRING is a string to complete. PREDICATE is a list of name types to return. See lyskom-read-conf for details. ALL is set by try-completion and all-completions. See the Emacs lisp manual for a description. Special value 'lyskom-lookup makes the function work as a name-to-conf-stat translator." ;; ;; Catch some degenerate cases that can cause...problems. This ;; won't solve all the...problems, but should speed things up a ;; little bit. ;; (cond ((and (null all) (string-match "^\\s-*$" string)) "") ((and (eq all 'lyskom-lookup) (string-match "^\\s-*$" string)) nil) ((and (eq all 'lambda) (string-match "^\\s-*$" string)) nil) (t (let* ((login-list (and (memq 'login predicate) (lyskom-read-conf-get-logins))) (x-list (lyskom-completing-lookup-z-name string (if (or (memq 'all predicate) (memq 'membership predicate) (memq 'conf predicate) (memq 'none predicate)) 1 0) (if (or (memq 'all predicate) (memq 'membership predicate) (memq 'pers predicate) (memq 'none predicate) (memq 'login predicate)) 1 0))) (r-list (when (assq 'restrict predicate) (let ((result (make-collector))) (lyskom-traverse conf-no (cdr (assq 'restrict predicate)) (initiate-get-uconf-stat 'main 'collector-push conf-no result)) (lyskom-wait-queue 'main) (delq nil (mapcar (lambda (conf-stat) (when (lyskom-completing-match-string string (conf-stat->name conf-stat)) (lyskom-create-conf-z-info (conf-stat->name conf-stat) (conf-stat->conf-type conf-stat) (conf-stat->conf-no conf-stat)))) (collector->value result)))))) (candidate-list (append r-list (if x-list (conf-z-info-list->conf-z-infos x-list)))) (result-list nil)) ;; ;; login-list now contains a list of logins, IF the predicate ;; includes 'login ;; ;; candidate-list contains a list of conf-z-infos ;; ;; Now set result-list to the conf-z-infos that fulfill the ;; predicate, fetching the conf-stats asynchronously. ;; (lyskom-traverse el candidate-list (if (lyskom-read-conf-internal-verify-type (conf-z-info->conf-no el) (conf-z-info->conf-type el) predicate login-list candidate-list) (setq result-list (cons el result-list)))) ;; ;; Now the matching conf-z-infos are in result-list ;; (cond ((eq all 'lyskom-lookup) (let ((names (mapcar 'conf-z-info->name result-list)) (specials (lyskom-read-conf-expand-specials string predicate login-list candidate-list))) (cond ((and kom-complete-numbers-before-names specials) (lyskom-read-conf-lookup-specials string predicate login-list candidate-list)) ((= (length result-list) 1) (car result-list)) ((and (> (length result-list) 1) (lyskom-completing-member string names)) (elt result-list (- (length result-list) (length (lyskom-completing-member string names))))) (specials (lyskom-read-conf-lookup-specials string predicate login-list candidate-list)) ((string-match (lyskom-get-string 'person-or-conf-no-regexp) string) nil) ((string-match (lyskom-get-string 'session-no-regexp) string) nil) ((lyskom-read-conf-internal-verify-type nil nil predicate login-list candidate-list) string)))) ;; ;; Check for exact match. We have an exact match in the server ;; when there was a single match OR when there was no match, and ;; no match is valid according to predicate ;; ((eq all 'lambda) (let ((specials (lyskom-read-conf-expand-specials string predicate login-list candidate-list))) (cond ((= (length result-list) 1) t) ((and (> (length result-list) 1) (let ((names (mapcar 'conf-z-info->name result-list))) (and (lyskom-completing-member string names) t)))) (result-list nil) ((= (length specials) 1) t) (specials nil) ((string-match (lyskom-get-string 'person-or-conf-no-regexp) string) nil) ((string-match (lyskom-get-string 'session-no-regexp) string) nil) (t (lyskom-read-conf-internal-verify-type nil nil predicate login-list candidate-list))))) ;; ;; Called from all-completions. Return a list of all possible ;; completions, in this case all names in the result list plus, ;; if the input string is a person or conf number specification, ;; the input string, PROVIDED, the requested conference matches ;; the predicate. If there were no matches, return the input ;; string if no matches satisfies the predicate. ;; (all (let ((names (mapcar 'conf-z-info->name result-list)) (specials (lyskom-read-conf-expand-specials string predicate login-list candidate-list))) (cond (specials (append specials names)) (names names) ((string-match (lyskom-get-string 'person-or-conf-no-regexp) string) nil) ((string-match (lyskom-get-string 'session-no-regexp) string) nil) ((lyskom-read-conf-internal-verify-type nil nil predicate login-list candidate-list) (list string)) (t nil)))) ;; ;; Called from try-completion, and there were no matches. Try to ;; expand the input string as a person or conf number ;; specification or return something sensible if the predicate ;; is satisfied by no matches. ;; ((null result-list) (let ((specials (lyskom-read-conf-expand-specials string predicate login-list candidate-list))) (cond (specials (car specials)) ((string-match (lyskom-get-string 'person-or-conf-no-regexp) string) nil) ((string-match (lyskom-get-string 'session-no-regexp) string) nil) ((lyskom-read-conf-internal-verify-type nil nil predicate login-list candidate-list) t) (t nil)))) ;; ;; Called from try-completion, and there were matches in the ;; server. Return t if the string is an exact match to any ;; string returned from the server. Otherwise, expand the string ;; as far as possible and return that ;; (t (let ((name-list (mapcar 'conf-z-info->name result-list)) (specials (lyskom-read-conf-expand-specials string predicate login-list candidate-list))) (if specials (setq name-list (nconc specials name-list))) (cond ((lyskom-completing-member string name-list) (or (and (= (length name-list) 1) t) string)) ; Exact match ((= (length name-list) 1) (car name-list)) ((string-match (lyskom-get-string 'person-or-conf-no-regexp) string) nil) ((string-match (lyskom-get-string 'session-no-regexp) string) nil) (t (or (lyskom-completing-cache-completion (lyskom-complete-string name-list) (if r-list (lyskom-create-conf-z-info-list (apply 'vector candidate-list)) x-list)) (and (lyskom-read-conf-internal-verify-type nil nil predicate login-list candidate-list) (list string)))))))))))) (defun lyskom-completing-member (string list) (let ((string (lyskom-unicase (lyskom-completing-strip-name string))) (result nil)) (while (and list (not result)) (if (lyskom-string= string (lyskom-unicase (lyskom-completing-strip-name (car list)))) (setq result list) (setq list (cdr list)))) result)) (defun lyskom-completing-strip-name (string) "Strip parens and crap from a name." (while (string-match "([^()]*)" string) (setq string (replace-match " " t t string))) (while (string-match "\\s-\\s-+" string) (setq string (replace-match " " t t string))) (while (string-match "([^()]*$" string) (setq string (substring string 0 (match-beginning 0)))) (if (string-match "^\\s-*\\(.*\\S-\\)\\s-*$" string) (match-string 1 string) string)) (defun lyskom-read-conf-internal-verify-type (conf-no conf-type predicate logins x-list) (or (memq conf-no (cdr (assq 'restrict predicate))) (and (memq 'all predicate) conf-no) (and (memq 'conf predicate) conf-type (not (conf-type->letterbox conf-type))) (and (memq 'pers predicate) conf-type (conf-type->letterbox conf-type)) (and (memq 'login predicate) conf-no (memq conf-no logins)) (and (memq 'membership predicate) conf-no (lyskom-get-membership conf-no t)) (and (memq 'none predicate) (and (null conf-no) (null x-list))))) ;;; FOR DEBUGGING (DON'T DELETE) /byers ;;; ;;; (defun lyskom-complete-show-data-list (state data) ;;; (save-excursion ;;; (pop-to-buffer (get-buffer-create "*kom*-complete")) ;;; (erase-buffer) ;;; (set-buffer-multibyte nil) ;;; (while data ;;; (insert ;;; (format "%s\n" (substring (aref (car data) 2) ;;; (aref (car data) 0) ;;; (aref (car data) 1)))) ;;; (setq data (cdr data))) ;;; (insert (format "%S %S: %S" (symbol-value current-state) ;;; (elt state 0) ;;; (elt state 1))) ;;; (sit-for 5))) (defun lyskom-complete-string (string-list) "Find the longest common prefix of all strings in STRING-LIST according to the LysKOM rules of string matching." (let ((main-state 'start-of-string) (tmp-state nil) (current-state 'main-state) (main-accumulator nil) (tmp-accumulator nil) (current-accumulator 'main-accumulator) (done nil) (paren-depth 0) (have-here nil) (last-event-worth-noting nil) (data-list (lyskom-complete-string-munge-input string-list)) (next-char-state (vector nil nil))) (while (not done) (lyskom-complete-string-next-char next-char-state data-list) ; (lyskom-complete-show-data-list next-char-state data-list) (cond ;; ;; Case one, a match of two non-special characters. ;; Accumulate one character and advance the lists ;; ((eq (aref next-char-state 0) 'match) (if (eq (aref next-char-state 1) ?\ ) (progn (cond ((memq (symbol-value current-state) '(start-of-word start-of-string)) nil) ((eq last-event-worth-noting 'mismatch) (lyskom-complete-string-accumulate current-accumulator 'SPC)) (t (lyskom-complete-string-accumulate current-accumulator ?\ ))) (set current-state 'start-of-word) (lyskom-complete-string-advance data-list)) (progn (set current-state 'in-a-word) (lyskom-complete-string-accumulate current-accumulator (aref next-char-state 1)) (lyskom-complete-string-advance data-list))) (setq last-event-worth-noting 'match)) ;; ;; Case two, a match of two open-paren expressions Increase ;; paren depth and accumulate a character. First set ;; current-accumulator to the temporary if paren-depth is zero ;; to start with. ;; ((eq (aref next-char-state 0) 'open-paren-match) (setq last-event-worth-noting 'match) (if (zerop paren-depth) (progn (setq current-accumulator 'tmp-accumulator) (setq current-state 'tmp-state) (setq tmp-state main-state) (setq tmp-accumulator nil))) (setq paren-depth (1+ paren-depth)) (lyskom-complete-string-accumulate current-accumulator (aref next-char-state 1)) (lyskom-complete-string-advance data-list)) ;; ;; Case three, a match of two close-paren expressions ;; Accumulate a character. If paren-depth is postitive, ;; decrease it. If it ends up zero, add the temporary ;; accumulator to the main accumulator and set the current ;; accumulator to the main accumulator. ;; ((eq (aref next-char-state 0) 'close-paren-match) (setq last-event-worth-noting 'match) (lyskom-complete-string-accumulate current-accumulator (aref next-char-state 1)) (if (> paren-depth 0) (progn (setq paren-depth (1- paren-depth)) (if (zerop paren-depth) (progn (setq main-accumulator (nconc tmp-accumulator main-accumulator)) (setq main-state tmp-state) (setq current-state 'main-state) (setq current-accumulator 'main-accumulator))))) (lyskom-complete-string-advance data-list)) ;; ;; Case two, a mismatch of any kind in a paren expression ;; ((and (> paren-depth 0) (memq (aref next-char-state 0) '(mismatch space-mismatch open-paren-mismatch))) (setq last-event-worth-noting 'mismatch) (setq tmp-accumulator nil) (setq tmp-state nil) (setq current-state 'main-state) (setq current-accumulator 'main-accumulator) (lyskom-complete-string-close-parens data-list paren-depth) (setq paren-depth 0)) ;; ;; Case two and a half or so, a space mismatch. This is ignored ;; if we're still at the start of the string ;; ((and (eq (aref next-char-state 0) 'space-mismatch) (memq (symbol-value current-state) '(start-of-string start-of-word))) (setq last-event-worth-noting nil) (lyskom-complete-string-skip-whitespace data-list)) ;; ;; Case three, a mismatch of regular characters outside a paren ;; Advance to the end of the current word ;; ((and (memq (aref next-char-state 0) '(mismatch space-mismatch)) (zerop paren-depth)) (setq last-event-worth-noting 'mismatch) (if (memq (symbol-value current-state) '(start-of-word start-of-string)) (setq done t) (progn (if (not have-here) (progn (lyskom-complete-string-accumulate current-accumulator 'HERE) (setq have-here t))) (lyskom-complete-string-advance-to-end-of-word data-list) (set current-state 'in-a-word)))) ;; ;; Case four, a mistmatch where one character is an open-paren ;; ((eq (aref next-char-state 0) 'open-paren-mismatch) (setq last-event-worth-noting 'mismatch) (lyskom-complete-string-skip-parens data-list)) ;; ;; Case five, eof ;; ((eq (aref next-char-state 0) 'eof) (setq done t)) ;; ;; Case six, can't happen ;; (t (error "This can't happen: %S" next-char-state)))) ;; ;; Build the result by reversing the result list and making a ;; string out of it. ;; (if (eq (car main-accumulator) 'SPC) (setq main-accumulator (cdr main-accumulator))) (setq main-accumulator (nreverse main-accumulator)) (if (memq 'HERE main-accumulator) (let ((backup (length (memq 'HERE main-accumulator)))) (if lyskom-experimental-features (setq unread-command-events (append (cons ? (make-list (1- backup) 2)) unread-command-events))) (setq main-accumulator (delq 'HERE main-accumulator)))) (concat (mapcar (lambda (el) (if (eq el 'SPC) ?\ el)) main-accumulator)))) (defun lyskom-complete-string-accumulate (accumulator char) (set accumulator (cons char (symbol-value accumulator)))) (defun lyskom-complete-string-munge-input (string-list) (mapcar (function (lambda (x) (vector 0 (length x) x))) string-list)) ;;; ;;; Advance one regular character or multiple whitespaces ;;; (defun lyskom-complete-string-advance (data-list) (lyskom-traverse el data-list (string-match "\\([ \t]+\\|[^ \t]\\|$\\)" (aref el 2) (aref el 0)) (aset el 0 (match-end 0)))) (defun lyskom-complete-string-skip-whitespace (data-list) (lyskom-traverse el data-list (string-match "[ \t]*" (aref el 2) (aref el 0)) (aset el 0 (match-end 0)))) ;;; ;;; Advance to the end of the current word ;;; (defun lyskom-complete-string-advance-to-end-of-word (data-list) (lyskom-traverse el data-list (aset el 0 (string-match "\\([ \t]\\|$\\)" (aref el 2) (aref el 0))))) ;;; ;;; Unwind a number of parens ;;; (defun lyskom-complete-string-skip-parens (data-list) (lyskom-traverse el data-list (if (eq ?\( (aref (aref el 2) (aref el 0))) (progn (aset el 0 (1+ (aref el 0))) (lyskom-complete-string-close-parens-2 el 1))))) (defun lyskom-complete-string-close-parens (data-list depth) (lyskom-traverse el data-list (lyskom-complete-string-close-parens-2 el depth))) (defun lyskom-complete-string-close-parens-2 (el depth) (let ((string (aref el 2)) (pos (aref el 0))) (while (> depth 0) (cond ((>= pos (length string)) (setq depth 0)) ((eq (aref string pos) ?\)) (setq depth (1- depth))) ((eq (aref string pos) ?\)) (setq depth (1+ depth)))) (setq pos (1+ pos))) (aset el 0 pos))) ;;; ;;; Check what's happenin' next ;;; (defun lyskom-complete-string-next-char (state data-list) (let ((eofp nil) (open-paren-p nil) (close-paren-p nil) (matchp t) (spacep nil) (char nil) (xchar nil)) (lyskom-save-excursion (set-buffer lyskom-buffer) (mapcar (function (lambda (x) (cond ((>= (aref x 0) (aref x 1)) (setq eofp t) (setq matchp nil)) ((eq (aref (aref x 2) (aref x 0)) ?\() (setq open-paren-p t)) ((eq (aref (aref x 2) (aref x 0)) ?\)) (setq close-paren-p t)) ((eq (aref (aref x 2) (aref x 0)) ?\ ) (setq spacep t))) (setq matchp (and matchp (if (null char) (progn (setq xchar (aref (aref x 2) (aref x 0))) (setq char (lyskom-unicase-char xchar))) (eq char (lyskom-unicase-char (aref (aref x 2) (aref x 0))))))))) data-list)) (aset state 1 xchar) (cond (eofp (aset state 0 'eof)) ((and matchp open-paren-p) (aset state 0 'open-paren-match)) ((and matchp close-paren-p) (aset state 0 'close-paren-match)) (matchp (aset state 0 'match)) (spacep (aset state 0 'space-mismatch)) (open-paren-p (aset state 0 'open-paren-mismatch)) (t (aset state 0 'mismatch)))) state) ;;; ============================================================ ;;; ;;; Session reading ;;; ;;; (defun lyskom-read-session-no (prompt &optional empty initial only-one) (let ((possible-matches (lyskom-session-from-conf (lyskom-read-conf-no prompt (if kom-permissive-completion '(pers) '(login)) empty initial t)))) (if (and (> (length possible-matches) 1) only-one) (lyskom-read-session-resolve-ambiguity possible-matches) possible-matches))) (defun lyskom-session-from-conf (conf-no) (let ((who-list (lyskom-completing-who-is-on)) (sessions nil)) (if (lyskom-have-feature dynamic-session-info) (while who-list (if (eq (dynamic-session-info->person (car who-list)) conf-no) (setq sessions (cons (dynamic-session-info->session (car who-list)) sessions))) (setq who-list (cdr who-list))) (while who-list (if (eq (who-info->pers-no (car who-list)) conf-no) (setq sessions (cons (who-info->connection (car who-list)) sessions))) (setq who-list (cdr who-list)))) (cond ((and (null sessions) kom-permissive-completion) (list (- conf-no))) (t sessions)))) (defun lyskom-read-session-resolve-ambiguity (sessions) (lyskom-insert "\n") (let* ((s-width (1+ (apply 'max (mapcar (function (lambda (x) (string-width (int-to-string x)))) sessions)))) (format-string-s (lyskom-info-line-format-string s-width "s" "s")) (format-string-p (lyskom-info-line-format-string s-width "P" "M"))) (lyskom-format-insert format-string-s "" (lyskom-get-string 'lyskom-name) (lyskom-get-string 'is-in-conf)) (lyskom-format-insert format-string-s "" (lyskom-get-string 'from-machine) (lyskom-get-string 'is-doing)) (lyskom-insert (concat (make-string (- (lyskom-window-width) 2) ?-) "\n")) (let ((result nil) (who-info (mapcar (function (lambda (el) (let* ((info (blocking-do 'get-session-info el)) (confconfstat (blocking-do 'get-uconf-stat (session-info->working-conf info)))) (lyskom-format-insert format-string-p (format "%d%s" (session-info->connection info) (if (eq (session-info->connection info) lyskom-session-no) "*" " ")) (session-info->pers-no info) (or confconfstat (lyskom-get-string 'not-present-anywhere))) (lyskom-format-insert format-string-p "" (lyskom-return-username info) (concat "(" (session-info->doing info) ")")) (cons (number-to-string (session-info->connection info)) info)))) (sort sessions '<)))) (lyskom-insert (concat (make-string (- (lyskom-window-width) 2) ?-) "\n")) (lyskom-insert (lyskom-format 'total-users-sans-date (length who-info))) (lyskom-scroll) (while (string= "" (setq result (lyskom-completing-read (lyskom-get-string 'resolve-session) (lyskom-maybe-frob-completion-table who-info) nil t (car (car who-info)) nil)))) (list (session-info->connection (cdr (assoc result who-info)))))))