;;;yaya:/usr/u/sra/m/WATSON/emacs/inquir.el, 15-Aug-1990 03:20:06, sra ;;; TO DO: ;;; ;;; The error reporting and handling is ugly, in particular the code ;;; that checks for a new entry by parsing the `Unknown UNAME "xxx"' ;;; output from lookup. Maybe use a simple win/lose header message ;;; like Chaos/MAIL and TCP/SFTP use. ;;; ;;; Hostname/mailboxname validation? ;;; ;;; Fix up old database before using it, what with the 512-byte entry ;;; size limit we don't really want to take up space for things like ;;; Twenex directory names. Also get rid of the obsolete field names ;;; "MITAD" and "MITTE", the proper names are "WRKAD" and "WRKTE". (defconst emacs-inquir-version 1) ;;; User-visible variables. (defconst inquir-client-program "/usr/local/bin/inquir") (defvar inquir-config-command (list inquir-client-program "-c") "*Command to run to get INQUIR configuration.") (defvar inquir-get-entry-command (list inquir-client-program "-l") "*Command to run to get a INQUIR entry from database.") (defvar inquir-set-entry-command (list inquir-client-program "-u") "*Command to run to update a INQUIR database entry.") (defvar inquir-new-uid-command (list inquir-client-program "-n") "*Command to get a new UID for a new user.") (defvar inquir-hacker-mode nil "*If non-nil, enables visibility of :obscure INQUIR fields in INQUIR. If you change the setting of this while running INQUIR, you probably want to use the List command to update the displayed fields.") ;;; There are two kinds of entries in the command table obarray: program ;;; commands and field names. These can be distinguished by invoking ;;; the test inquir-field-p. The associated data for field names is kept ;;; in the plist. All entries are capitalized, that is, the expression ;;; (intern (capitalize (completing-read table nil t)) table) ;;; should find the table entry that was parsed. (defvar inquir-obarray) (defvar inquir-tag-alist nil) (defun inquir-init () (message "Configuring INQUIR...") (mapcar (function (lambda (x) (set x x))) '(:help :tag :function :type :regexp :keys :index :obscure :keyword :line :text :birthday)) (setq inquir-obarray (make-vector 11 0)) (mapcar (function (lambda (x) (let ((sym (intern (concat "inquir-" (downcase x))))) (and (fboundp sym) (fset (intern x inquir-obarray) sym))))) '("All" "Exit" "Help" "Kill" "List" "Done" "Quit" "Rename" "Verbose" "Whois" "Zero")) (inquir-config) (let (alist) (mapatoms (function (lambda (x) (if (inquir-field-p x) (setq alist (cons (cons (get x :tag) x) alist))))) inquir-obarray) (setq inquir-tag-alist (sort alist (function (lambda (a b) (< (get (cdr a) :index) (get (cdr b) :index))))))) (mapcar (function (lambda (x) (make-variable-buffer-local x) (setq-default x nil))) '(inquir-data-alist inquir-modified inquir-uname inquir-suname)) (message "Configuring INQUIR...done")) ;;; The following two forms are used in the config file downloaded from the server (defun inquir-define (name &rest plist) (let ((sym (intern (capitalize name) inquir-obarray))) (setplist sym plist) (fset sym 'inquir-dispatch) (put sym :index (setq inquir-index (1+ inquir-index))) (put sym :function (cdr (assq (get sym :type) '((:line . inquir-read-line) (:text . inquir-read-text) (:keyword . inquir-read-keyword) (:birthday . inquir-read-birthday))))))) (defun inquir-current-version (&rest versions) (let ((most-current-version (cdr (assoc 'emacs versions)))) (if (< emacs-inquir-version most-current-version) (progn (message "You have an old version of the INQUIR client. You should get version %s." most-current-version) (sit-for 5))))) (defun inquir-config () (let (buffer (inquir-index 0)) (unwind-protect (save-excursion (set-buffer (setq buffer (get-buffer-create " inquir temp"))) (erase-buffer) (apply 'call-process (or (car-safe inquir-config-command) inquir-config-command) nil t nil (cdr-safe inquir-config-command)) ;; What the hell, you only die once.... (goto-char (point-min)) (while (search-forward "\r\n" nil t) (replace-match "\n")) (eval-current-buffer)) (if buffer (kill-buffer buffer))))) (defun inquir-field-p (sym) (eq (symbol-function sym) 'inquir-dispatch)) (defun inquir-visible-p (sym) (or inquir-hacker-mode (not (get sym :obscure)))) (defun inquir-prompt (sym) (concat (symbol-name sym) ": ")) (defun inquir-data (sym) (cdr (assq sym inquir-data-alist))) (defun inquir-field (field) (cdr (assoc (cdr (assoc field inquir-tag-alist)) inquir-data-alist))) (defconst inquir-months '(("January" . 31) ("February" . 29) ("March" . 31) ("April" . 30) ("May" . 31) ("June" . 30) ("July" . 31) ("August" . 31) ("September" . 30) ("October" . 31) ("November" . 30) ("December" . 31))) (defconst inquir-birthdays nil) (defun inquir-birthdays-init () ;; We only construct this horrid table if the user is actually parsing ;; birthdays. This mechanism is amazingly gross and should be ;; replaced with something reasonable. (apply 'nconc (mapcar (function (lambda (x) (let (r (m (car x)) (i (cdr x))) (while (< 0 i) (setq r (cons (list (format "%s %d" m i)) r) i (1- i))) r))) inquir-months))) (defun inquir-read-birthday (sym) (or inquir-birthdays (setq inquir-birthdays (inquir-birthdays-init))) (capitalize (completing-read (inquir-prompt sym) inquir-birthdays nil t (inquir-data sym)))) (defun inquir-read-line (sym) (let ((prompt (inquir-prompt sym)) (result (inquir-data sym)) (regexp (get sym :regexp))) (catch 'return (while t (setq result (read-string prompt result)) (if (or (equal "" result) (null regexp) (string-match regexp result)) (throw 'return result)) (beep) (message "%s" (or (get sym :help) "Bad data for undocumented field")) (sit-for 5))))) (defvar inquir-text-map (let ((map (copy-keymap text-mode-map))) (define-key map "\C-c\C-c" 'exit-recursive-edit) (define-key map "\C-c\C-]" 'abort-recursive-edit) map)) (defun inquir-text-mode () "Major mode for editing long fields in INQUIR. Don't call this yourself. Runs hooks text-mode-hook and inquir-text-mode-hook, in that order. Commands in local keymap: \\{inquir-text-map}" (kill-all-local-variables) (use-local-map inquir-text-map) (setq mode-name "Inquir-Text") (setq major-mode 'inquir-text-mode) (setq local-abbrev-table text-mode-abbrev-table) (set-syntax-table text-mode-syntax-table) ;; Finger displays fields like REMARKS indented by one tab stop, and ;; we assume the usual convention of breaking lines near column 70. (setq fill-column 62) (run-hooks 'text-mode-hook 'inquir-text-mode-hook)) ;; This is probably not needed, but be paranoid (put 'inquir-text-mode 'mode-class 'special) (defun inquir-read-text (sym) (let (buffer (data (inquir-data sym)) (doc (get sym :help)) (regexp (get sym :regexp))) (unwind-protect (save-excursion (save-window-excursion (switch-to-buffer (setq buffer (get-buffer-create (concat "*" (symbol-name sym) "*")))) (inquir-text-mode) (erase-buffer) (if data (insert data)) (catch 'return (while t (recursive-edit) (if (or (null regexp) (zerop (buffer-size)) (save-excursion (goto-char (point-min)) (looking-at regexp))) (throw 'return (buffer-string))) (message "%s" doc) (sit-for 5))))) (and buffer (kill-buffer buffer))))) (defun inquir-read-keyword (sym) (let* ((keylist (get sym :keys)) (key (downcase (completing-read (inquir-prompt sym) (mapcar 'list keylist) nil t (inquir-data sym))))) (while (and keylist (not (equal key (downcase (car keylist))))) (setq keylist (cdr keylist))) (car keylist))) (defun inquir-command-loop () ;; NB: "Quit" throws nil, "Exit" (synonym "Done") and "Kill" throw t. (catch 'inquir-finished (while t (let (ccvar) (condition-case ccvar (let* ((completion-ignore-case t) (key (capitalize (completing-read "Inquir> " inquir-obarray 'inquir-visible-p t))) (cmd (intern-soft key inquir-obarray))) (condition-case ccvar (funcall cmd cmd) (void-function (if (not (equal key "")) (progn (message "`%s' command not yet implemented." key) (sit-for 5)))) (quit))) (quit (inquir-quit)) ;; Trapping 'error is a real can of worms. The following ;; crock is based on the internal code in keyboard.c. (error (let ((head (get (car ccvar) 'error-message)) (tail (cdr ccvar))) (cond ((eq 'error (car ccvar)) (setq head (car tail) tail nil)) ((memq 'file-error (get (car ccvar) 'error-conditions)) (setq head (car tail) tail (cdr tail)))) (if (null tail) (message "%s" head) (message "%s: %s" head (mapconcat 'identity tail ", ")))) (sit-for 5))))))) (defun inquir-exit (&optional ignored) "Exit INQUIR, saving changes." (throw 'inquir-finished t)) (defun inquir-done (&optional ignored) "Exit INQUIR, saving changes." (throw 'inquir-finished t)) (defun inquir-quit (&optional ignored) "Quit INQUIR, discarding changes." (if (or (and (not inquir-modified) (not inquir-newbie)) (yes-or-no-p "Are you sure you want to QUIT, discarding all changes? ")) (throw 'inquir-finished nil)) (message "Not confirmed.") (sit-for 5)) (defun inquir-help (&optional ignored) "Pop up window with help information for INQUIR." (require 'ehelp) (with-electric-help (function (lambda () (let (cmds flds) (mapatoms (function (lambda (x) (if (inquir-visible-p x) (if (inquir-field-p x) (setq flds (cons x flds)) (setq cmds (cons x cmds)))))) inquir-obarray) (setq cmds (sort cmds 'string-lessp) flds (sort flds 'string-lessp)) (insert "This is INQUIR, the INQUIR database user interface. The following commands are used to update specific database fields:\n\n") (while flds (insert (symbol-name (car flds)) ":\n" (get (car flds) :help) "\n\n") (setq flds (cdr flds))) (insert "The following are general program commands:\n\n") (while cmds (let (ccvar (x (car cmds))) (insert (symbol-name x) ":\n" (condition-case ccvar (or (documentation x) "Not documented.") (void-function "Not yet implemented.")) "\n\n")) (setq cmds (cdr cmds)))))))) (defun inquir-list (&optional ignored) "Force updated display of all INQUIR fields." (let (buffer-read-only) (erase-buffer) (setq inquir-data-column 0) (mapcar (function (lambda (x) (cond ((inquir-visible-p (cdr x)) (insert (symbol-name (cdr x)) ": ") (let ((len (current-column))) (if (< inquir-data-column len) (setq inquir-data-column len))) (insert "\n"))))) inquir-tag-alist) (goto-char (point-min)) (end-of-line) (while (not (eobp)) (let ((diff (- inquir-data-column (current-column)))) (or (zerop diff) (insert (make-string diff ? )))) (end-of-line 2))) (mapcar (function (lambda (x) (inquir-display (cdr x)))) inquir-tag-alist) (goto-char (point-min))) (defun inquir-display (sym) (let (buffer-read-only) (goto-char (point-min)) (cond ((re-search-forward (concat "^" (regexp-quote (symbol-name sym)) ":") nil t) (forward-char (- inquir-data-column (current-column))) (let ((start (point)) end) (re-search-forward "^[^ \t]" nil 0) (end-of-line 0) (delete-region start (point)) (insert (or (inquir-data sym) "")) (setq end (point-marker)) (goto-char start) (while (search-forward "\n" end t) (insert-before-markers (make-string inquir-data-column ? ))) (set-marker end nil) (goto-char start)))))) (defun inquir-dispatch (sym) (inquir-display sym) (let* ((val (funcall (get sym :function) sym)) (cell (assq sym inquir-data-alist))) (cond ((equal (cdr cell) val)) (t (if cell (setcdr cell val) (setq inquir-data-alist (nconc inquir-data-alist (list (cons sym val))))) (setq inquir-modified t) (inquir-display sym))))) (defvar inquir-newbie nil) (defun inquir-new-uid () (let (buffer) (unwind-protect (save-excursion (set-buffer (setq buffer (get-buffer-create "inquir temp 2"))) (erase-buffer) (apply 'call-process (or (car-safe inquir-new-uid-command) inquir-new-uid-command) nil t nil (cdr-safe inquir-new-uid-command)) (goto-char (point-min)) (looking-at "\\([0-9]*\\)") (buffer-substring (match-beginning 1) (match-end 1))) (if buffer (kill-buffer buffer))))) (defun inquir-get-entry (uname) (let (buffer) (setq inquir-newbie nil) (unwind-protect (save-excursion (set-buffer (setq buffer (get-buffer-create " inquir temp"))) (erase-buffer) (apply 'call-process (or (car-safe inquir-get-entry-command) inquir-get-entry-command) nil t nil (append (cdr-safe inquir-get-entry-command) (list uname))) (goto-char (point-min)) (while (search-forward "\r\n" nil 0) (replace-match "\n")) (cond ((equal (concat "Unknown UNAME \"" (upcase uname) "\"\n") (buffer-string)) (if (yes-or-no-p (concat "Unknown user " uname " - create new entry? ")) (progn (setq inquir-newbie t) (let ((untag (cdr (assoc "UNAME" inquir-tag-alist))) (uidtag (cdr (assoc "UID" inquir-tag-alist)))) (list (cons untag uname) (cons uidtag (inquir-new-uid))))) (error "`%s' not created." uname))) (t (while (not (bobp)) (goto-char (point-min)) (while (re-search-forward "^\\([^: \t]*\\)[ \t]+" nil t) (replace-match "\\1"))) (let (alist) (while (looking-at "\\([A-Z]*\\):\\(.*\\)$") (let ((tag (buffer-substring (match-beginning 1) (match-end 1))) (val (buffer-substring (match-beginning 2) (match-end 2)))) (cond ((not (equal tag "")) (setq alist (cons (cons (or (cdr (assoc tag inquir-tag-alist)) tag) val) alist))) ((null alist) (error "Naked continuation in entry for `%s'" uname)) (t (setcdr (car alist) (concat (cdr (car alist)) "\n" val))))) (forward-line) (delete-region (point-min) (point))) (or (zerop (buffer-size)) (error "Bad syntax in entry for `%s'" uname)) (sort alist (function (lambda (x y) (let ((xx (car x)) (yy (car y))) (and (symbolp xx) (or (stringp yy) (< (get xx :index) (get yy :index)))))))))))) (if buffer (kill-buffer buffer))))) (defun inquir-alter-id () (let* ((date (read (concat "(" (current-time-string) ")"))) (month (nth 1 date)) (day (nth 2 date)) (time (nth 3 date)) (year (nth 4 date))) (format "%s@%s %s-%s-%s %s" (user-real-login-name) (system-name) day month year time))) (defun inquir-set-entry () (let (buffer (alist inquir-data-alist) (suname inquir-suname)) (unwind-protect (save-excursion (set-buffer (setq buffer (get-buffer-create " inquir temp"))) (erase-buffer) (insert "BEGIN:\r\n" "SUNAME:" suname "\r\n") (insert "ALTER:" (inquir-alter-id) "\r\n") (mapcar (function (lambda (x) (let ((tag (car x))) (save-excursion (insert (if (symbolp tag) (get tag :tag) tag) ":" (cdr x)))) (while (search-forward "\n" nil 0) (replace-match "\r\n:")) (insert "\r\n"))) alist) (insert "END:\r\n") (save-excursion (apply 'call-process-region (point-min) (point-max) (or (car-safe inquir-set-entry-command) inquir-set-entry-command) t t nil (cdr-safe inquir-set-entry-command))) (if (eobp) nil (save-excursion (while (re-search-forward "\\(\r?\n\\)+ *" nil t) (replace-match "; "))) (buffer-substring (point) (point-max)))) (if buffer (kill-buffer buffer))))) (defvar inquir-default-uname (user-real-login-name)) (defun inquir (&optional uname) "Top-level function for INQUIR database utility. In brief, this function runs a special command loop inside emacs, allowing you to create, edit, and delete entries in an INQUIR-style database." ;; We can't use standard interactive parsing because we may be ;; invoked via -funcall when emacs is started up. So fake it. (interactive) (if (null uname) (setq uname (read-string "Run INQUIR for user: " inquir-default-uname))) (if (equal "" uname) (message "You have to specify a username for INQUIR to work with.") (let (buffer) (unwind-protect (save-excursion (save-window-excursion (setq inquir-default-uname uname) (let ((data (inquir-get-entry uname))) (switch-to-buffer (setq buffer (get-buffer-create "*inquir*"))) (fundamental-mode) (setq buffer-read-only t) (delete-other-windows) (setq inquir-data-alist data inquir-uname uname inquir-suname uname)) (setq inquir-modified inquir-newbie) (run-hooks 'inquir-hook) (inquir-list) (if (not (and (inquir-command-loop) inquir-modified)) (if (not (or inquir-modified inquir-newbie)) (message "No changes to entry `%s' so no update needed." inquir-uname) (message "Entry `%s' not updated." inquir-uname)) (message "Updating entry `%s'..." inquir-uname) (inquir-set-entry) (message "Updating entry `%s'...done" inquir-uname)))) (and buffer (kill-buffer buffer)))))) (defun inquir-all (&optional ignored) "Edit the values of each field, one at a time." (mapcar (function (lambda (x) (and (inquir-visible-p (cdr x)) (inquir-dispatch (cdr x))))) inquir-tag-alist)) (defun inquir-kill (&optional ignored) "Delete a database entry. Requires confirmation." (if (not (yes-or-no-p (format "Are you SURE you want to delete the entry for `%s'? " inquir-uname))) (error "Not confirmed.") (let ((inhibit-quit t)) (setq inquir-data-alist nil inquir-modified t) (throw 'inquir-finished t)))) ;;; Support for fake-password entry ;;; There has *got* to be a better way. (defun digitp (x) (cond ((string= x "0") t) ((string= x "1") t) ((string= x "2") t) ((string= x "3") t) ((string= x "4") t) ((string= x "5") t) ((string= x "6") t) ((string= x "7") t) ((string= x "8") t) ((string= x "9") t) (t nil))) ;;; CHFN takes ensures that phone numbers have only digits in them. ;;; According to the UN*X way, someone doubtless depends on this. So ... (defun eliminate-all-but-digits (input) (let ((i 0) (output "") char) (while (< i (length input)) (if (digitp (setq char (substring input i (1+ i)))) (setq output (concat output char))) (setq i (1+ i))) output)) (defun fake-password-entry (&optional uname) "Assemble a UN*X /etc/passwd entry from an inquir record, for convenience' sake when making accounts. Inserts the result at point (the location of the cursor) assuming group membership 100 and shell /usr/site/tcsh" (interactive) (if (null uname) ;; default to nullstring here, since this will usually be called by a sysadmin ;; on behalf of someone else (setq uname (read-string "Insert password entry for user: " ""))) (if (equal "" uname) (message "You have to specify a username for INQUIR to work with.") (let* ((inquir-data-alist (inquir-get-entry uname)) (name (downcase (inquir-field "UNAME")))) ;; Note that the GID defaults to 100, and the shell to tcsh. Sorry. (insert (concat name ":*:" (inquir-field "UID") ":100:" (inquir-field "NAME") "," (inquir-field "WRKAD") "," (eliminate-all-but-digits (inquir-field "WRKTE")) "," (eliminate-all-but-digits (inquir-field "HOMTE")) ":/u/" name ":/usr/site/tcsh"))))) ;;; Here's some output from the above ;;; nick:*:11183:100:Nicholas Papadakis,NE43-254,36524,6176614938:/u/nick:/usr/site/tcsh ;; This should remain at the end of the file. (inquir-init)