home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / languages / elisp / packages / rpc-hm-1.0 / rpc-hm.el < prev    next >
Encoding:
Text File  |  1992-05-07  |  29.9 KB  |  780 lines
  1. ;Author: Eyvind Ness (eyvind) 
  2. ;Date:   Thursday, May 7 1992 19:48 GMT
  3. ;File:   /usr/local/gnu/emacs/elisp/site-extensions/rpc-hm.el
  4.  
  5. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  6. ;;; This is an Emacs Lisp package providing an interface to an RPC-like
  7. ;;; communication protocol called rpc-hm ("Home-made RPC").
  8. ;;; Both RPC/UDP and IP/TCP based communication transports are provided.
  9.  
  10. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  11. ;;;
  12. ;;;     Copyright (C) 1991, 1992 Eyvind Ness.
  13. ;;;
  14. ;;;     Permission to use, copy, modify, and distribute this software and its
  15. ;;;     documentation for non-commercial purposes and without fee is hereby
  16. ;;;     granted, provided that the above copyright notice appear in all copies
  17. ;;;     and that both the copyright notice and this permission notice appear in
  18. ;;;     supporting documentation. OECD Halden Reactor Project makes no
  19. ;;;     representations about the suitability of this software for any purpose.
  20. ;;;     It is provided "as is" without express or implied warranty.
  21. ;;;
  22. ;;;     OECD Halden Reactor Project disclaims all warranties with regard to this
  23. ;;;     software, including all implied warranties of merchantability and
  24. ;;;     fitness, and in no event shall OECD Halden Reactor Project be liable for
  25. ;;;     any special, indirect or consequential damages or any damages whatsoever
  26. ;;;     resulting from loss of use, data or profits, whether in an action of
  27. ;;;     contract, negligence or other tortious action, arising out of or in
  28. ;;;     connection with the use or performance of this software.
  29. ;;;
  30. ;;;
  31. ;;;     Eyvind Ness
  32. ;;;     Research Scientist
  33. ;;;     Control Room Systems Division
  34. ;;;     OECD Halden Reactor Project
  35. ;;;     Norway
  36. ;;;
  37. ;;;     Internet Email: eyvind@hrp.no
  38. ;;;     Voice: +47 9 183100
  39. ;;;     Fax: +47 9 187109
  40. ;;;     Surface mail: P.O. Box 173, N-1751 Halden, Norway
  41.  
  42. (require 'ascii-filter)
  43. (provide 'rpc-hm)
  44. (defconst rpc-hm-version "1.0")
  45.  
  46. (defvar rpc-hm-host-db
  47.   '((remulus 
  48.      (type . :lispm)
  49.      (current-medium-ix . 0)
  50.      (rpc-hm-support :ip-tcp :rpc-udp))
  51.     (alfa
  52.      (type . :lispm)
  53.      (current-medium-ix . 0)
  54.      (rpc-hm-support :ip-tcp)))
  55.   "A database of hostnames and the protocols they support")
  56.  
  57.  
  58. (defvar rpc-hm-default-host-entry
  59.   '(default
  60.      (type :unix)
  61.      (current-medium-ix . 0)
  62.      (rpc-hm-support :rpc-udp))
  63.   "Default entry for hosts not in rpc-hm-host-db")
  64.  
  65.  
  66. (defvar rpc-hm-major-modes-with-auto-mode-line-update
  67.   '(lispm-mode common-lisp-mode)
  68.   "List of mode names (symbols) that may have their mode-line-string
  69. altered by functions in this library.")
  70.  
  71.  
  72. (defvar rpc-hm-startup-message-displayed-p nil)
  73. (defconst rpc-hm-startup-message-lines
  74.     '("Mail bug reports to bug-rpc-hm@hrp.no"
  75.       "RPC HM comes with ABSOLUTELY NO WARRANTY"
  76.       "Type \\[describe-no-warranty] for full details"))
  77.  
  78.  
  79. (defun rpc-hm-display-startup-message ()
  80.   ;; Stolen from Kyle Jones' VM package
  81.   (let ((lines rpc-hm-startup-message-lines))
  82.     (message "RPC HM version %s, Copyright (C) 1992 Eyvind Ness"
  83.          rpc-hm-version)
  84.     (while (and (sit-for 3) lines)
  85.       (message (substitute-command-keys (car lines)))
  86.       (setq lines (cdr lines)))
  87.     (or lines (setq rpc-hm-startup-message-displayed-p t)))
  88.   (message ""))
  89.  
  90.  
  91. (defvar rpc-hm-current-host-db-ix 0)
  92. (make-variable-buffer-local 'rpc-hm-current-host-db-ix)
  93.  
  94.  
  95. (defun rpc-hm-get-host-att (host att)
  96.   (or (symbolp host)
  97.       (if (not (stringp host))
  98.       (error "Illegal arg - HOST should be string or symbol")
  99.     (setq host (intern host))))
  100.   (let ((host-ent (or (assq host rpc-hm-host-db)
  101.               rpc-hm-default-host-entry)))
  102.     (cdr (assq att host-ent))))
  103.  
  104.  
  105. (defun rpc-hm-set-host-att (host att newval)
  106.   (or (symbolp host)
  107.       (if (not (stringp host))
  108.       (error "Illegal arg - HOST should be string or symbol")
  109.     (setq host (intern host))))
  110.   (let ((host-ent (or (assq host rpc-hm-host-db)
  111.               rpc-hm-default-host-entry)))
  112.     (let ((place (assq att host-ent)))
  113.       (and place (setcdr place newval)))))
  114.  
  115.  
  116. (defun rpc-hm-get-current-host ()
  117.   (car (elt rpc-hm-host-db rpc-hm-current-host-db-ix)))
  118.  
  119.  
  120. (defun rpc-hm-set-current-host (newhost)
  121.   (let ((pos (memq newhost (mapcar (function car) rpc-hm-host-db))))
  122.     (if pos
  123.     (setq rpc-hm-current-host-db-ix
  124.           (- (length rpc-hm-host-db)
  125.          (length pos))))
  126.     (prog1 (rpc-hm-get-current-host)
  127.       (rpc-hm-update-mode-line-if-convenient))))
  128.       
  129.  
  130. (defun rpc-hm-next-host (arg)
  131.   "Picks a new default host from rpc-hm-host-db. Alternatively, with a
  132. non-nil prefix arg a new default transport medium is chosen for the
  133. current host."
  134.   (interactive "P")
  135.   (if arg (prog1 (rpc-hm-get-current-host)
  136.         (rpc-hm-next-medium (rpc-hm-get-current-host)))
  137.     (prog2
  138.      (setq rpc-hm-current-host-db-ix
  139.        (mod (1+ rpc-hm-current-host-db-ix)
  140.         (length rpc-hm-host-db)))
  141.      (rpc-hm-get-current-host)
  142.      (rpc-hm-update-mode-line-if-convenient))))
  143.  
  144.  
  145. (defun rpc-hm-next-medium (host)
  146.   "Picks a new default transport medium from the rpc-hm-support list of
  147. HOST in rpc-hm-host-db."
  148.   (interactive)
  149.   (let ((medium-list (rpc-hm-get-host-att host 'rpc-hm-support))
  150.     (mix (rpc-hm-get-host-att host 'current-medium-ix)))
  151.     (prog1
  152.     (elt medium-list
  153.          (rpc-hm-set-host-att
  154.           host 'current-medium-ix
  155.           (mod (1+ mix) (length medium-list))))
  156.       (rpc-hm-update-mode-line-if-convenient))))
  157.  
  158.     
  159. (defun rpc-hm-update-mode-line-if-convenient ()
  160.   (if (memq major-mode rpc-hm-major-modes-with-auto-mode-line-update)
  161.       (progn
  162.     ;; NB! this surgery presupposes:
  163.     (make-local-variable 'global-mode-string)
  164.     (make-local-variable 'rpc-hm-mode-line-string)
  165.     ;; to limit the effect of altering the global-mode-string to the
  166.     ;; current buffer.
  167.     (setq global-mode-string
  168.           (list "" 'rpc-hm-mode-line-string))
  169.     (setq rpc-hm-mode-line-string
  170.           (concat
  171.            "Lispm@"
  172.            (prin1-to-string (rpc-hm-get-current-host))
  173.            " over "
  174.            (prin1-to-string
  175.         (elt
  176.          (rpc-hm-get-host-att
  177.           (rpc-hm-get-current-host) 'rpc-hm-support)
  178.          (rpc-hm-get-host-att
  179.           (rpc-hm-get-current-host) 'current-medium-ix)))))
  180.     (save-excursion (set-buffer (other-buffer)))
  181.     (set-buffer-modified-p (buffer-modified-p))
  182.     (sit-for 0))))
  183.  
  184.  
  185. ;;; Some handy condition type definitions. Use these to trap common
  186. ;;; errors singaled by this software.
  187. (put 'rpc-hm-network-condition
  188.      'error-conditions '(rpc-hm-network-condition error))
  189. (put 'rpc-hm-network-condition
  190.      'error-message "Networking problem")
  191.  
  192. (put 'rpc-hm-network-connection-error
  193.      'error-conditions
  194.      '(rpc-hm-network-connection-error rpc-hm-network-condition error))
  195. (put 'rpc-hm-network-connection-error
  196.      'error-message "Connection failure")
  197.  
  198. (put 'rpc-hm-network-server-condition
  199.      'error-conditions
  200.      '(rpc-hm-network-server-condition rpc-hm-network-condition error))
  201. (put 'rpc-hm-network-server-condition 
  202.      'error-message "Remote lisp server barfed")
  203.  
  204. ;;; Obsolete condition:
  205. ;;; (put 'rpc-hm-illegal-reader-macro
  206. ;;;      'error-conditions
  207. ;;;      '(rpc-hm-illegal-reader-macro rpc-hm-network-condition error))
  208. ;;; (put 'rpc-hm-illegal-reader-macro
  209. ;;;      'error-message "Remote reader macro unknown")
  210. ;;;
  211. ;;; Unused (as of version 1.0) condition:
  212. ;;; (put 'rpc-hm-network-client-condition
  213. ;;;      'error-conditions 
  214. ;;;      '(rpc-hm-network-client-condition rpc-hm-network-condition error))
  215. ;;; (put 'rpc-hm-network-client-condition
  216. ;;;      'error-message
  217. ;;;      ;; server protocol violation or condition escaped client trap
  218. ;;;      "Client error")
  219.  
  220.  
  221. (defun rpc-hm-read-from-string (str)
  222.   (car (read-from-string str)))
  223.  
  224.  
  225. ;;; Need a CL conformant syntax table to make elisp parsing work - see
  226. ;;; lisp-mode-variables () in lisp-mode.el:
  227. (defvar rpc-hm-lisp-mode-syntax-table
  228.   (progn
  229.     (setq rpc-hm-lisp-mode-syntax-table
  230.       (copy-syntax-table emacs-lisp-mode-syntax-table))
  231.     (let* ((const "!$%&*+-./0123456789:<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz[]^_{}~")
  232.        (i 0))
  233.       (while (< i (length const))
  234.     (modify-syntax-entry (aref const i) "w" rpc-hm-lisp-mode-syntax-table)
  235.     (setq i (1+ i))))
  236.     (modify-syntax-entry ?\| "\"   "
  237.              rpc-hm-lisp-mode-syntax-table)
  238.     (modify-syntax-entry ?\# "'   "
  239.              rpc-hm-lisp-mode-syntax-table)
  240.     (modify-syntax-entry ?\[ "_   "
  241.              rpc-hm-lisp-mode-syntax-table)
  242.     (modify-syntax-entry ?\] "_   "
  243.              rpc-hm-lisp-mode-syntax-table)
  244.     rpc-hm-lisp-mode-syntax-table))
  245.  
  246.  
  247. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  248. ;;; Tricky test cases for rpc-hm-forward-cl-sexp:
  249. ;;;
  250. ;;; non CL conforming Explorer pathname:
  251. ;;; (T #FS::LISPM-PATHNAME "REMULUS: EYVIND.LIB; CLISP.XLD#>" "" "" "" "" "" "")
  252. ;;; CLOS test:
  253. ;;; (defclass man->robot-> () ())
  254. ;;;
  255. ;;; (T #<Package USER (really COMMON-LISP-USER) 55711255>
  256. ;;;  "Package COMMON-LISP-USER.  Nicknames: CL-USER.
  257. ;;;   979 symbols out of 1631.  Hash modulus=2039.  48% full.
  258. ;;; New symbols added via SI:PKG-NEW-SYMBOL.  Colon prefix looks up symbols via SI:INTERN-EXTERNAL-ONLY.
  259. ;;; Uses package SYMBOLICS-COMMON-LISP.
  260. ;;; Relative names inherited from SYMBOLICS-COMMON-LISP:
  261. ;;;     USER                #<Package USER (really COMMON-LISP-USER) 55711255>
  262. ;;;     ZL                  #<Package ZL (really GLOBAL) 55217550>
  263. ;;; #<Package USER (really COMMON-LISP-USER) 55711255> is implemented as an ART-Q type array.
  264. ;;; It uses %ARRAY-DISPATCH-LEADER; it is 4,078 elements long, with a leader of length 16.
  265. ;;; "
  266. ;;;  "" "" "" "" "")
  267. ;;;
  268. ;;; ...this is getting out of hand - i'll change the protocol to always
  269. ;;; return a string value - using the new macro
  270. ;;; enlib:with-errors-and-io-trapped instead.
  271. ;;;
  272. ;;;
  273. ;;; (defun rpc-hm-forward-cl-sexp (&optional arg)
  274. ;;;   "Move forward across one balanced Common Lisp expression.
  275. ;;; With argument, do this that many times.
  276. ;;; See CLtL2, pp530- for the specification of #-reader macros.
  277. ;;;
  278. ;;; Warning! This function depends on the reply format of the underlying
  279. ;;; rpc-hm protocol and the use of enlib:with-errors-and-io-trapped on the
  280. ;;; server side - see rpc-hm-parse-ans. It is not a good idea to use
  281. ;;; this function for general purposes."
  282. ;;; ;; This anomaly exists due to the difficulty of parsing #<...> replies
  283. ;;; ;; correctly, see below.
  284. ;;;
  285. ;;;   (interactive "p")
  286. ;;;   (or arg (setq arg 1))
  287. ;;;   (let ((case-fold-search t)
  288. ;;;         (omd (match-data))
  289. ;;;         ;; (stab (syntax-table))
  290. ;;;         (signaller
  291. ;;;          (function (lambda ()
  292. ;;;            (signal 'rpc-hm-illegal-reader-macro
  293. ;;;                    (list
  294. ;;;                     (buffer-substring
  295. ;;;                      (point) (min (point-max) (+ 10 (point))))))))))
  296. ;;;     (unwind-protect
  297. ;;;          ;; (set-syntax-table
  298. ;;;          ;;   (copy-syntax-table rpc-hm-lisp-mode-syntax-table))
  299. ;;;          (cond ((looking-at "#<")
  300. ;;;                 ;; The #<...> special case.
  301. ;;;                 (if (re-search-forward ">\\s \"" (point-max) t)
  302. ;;;                     ;; Note: #<...> depends on being followed by a
  303. ;;;                     ;; whitespace character and a \".
  304. ;;;                     (forward-char -2)
  305. ;;;                     (signal 'rpc-hm-illegal-reader-macro
  306. ;;;                             (list
  307. ;;;                              (format
  308. ;;;                               "\"#<\"-%s \">\" returned from server."
  309. ;;;                               "reader macro without a matching")))))
  310. ;;;                ((looking-at "#\\\\\\(\\S \\)+")
  311. ;;;                 ;; a CL character object:
  312. ;;;                 ;; hash, backslash, N non-whitespace chars
  313. ;;;                 (goto-char (match-end 0)))
  314. ;;;                ((looking-at "#\\\\\\(\\s \\)")
  315. ;;;                 ;; hash, backslash, whitespace: illegal
  316. ;;;                 (funcall signaller))
  317. ;;;                ((looking-at "#\\\\\\(\n\\)")
  318. ;;;                 ;; same, but LFD isn't whitespace in lisp-mode
  319. ;;;                 (funcall signaller))
  320. ;;;                ((looking-at "#\C-p[^\C-q]*\C-q")
  321. ;;;                 ;; CL abusing Explorer pathname syntax
  322. ;;;                 (goto-char (match-end 0)))
  323. ;;;                ((looking-at "#\\([0-9]\\)*\\(\\S \\)")
  324. ;;;                 ;; any other, legal, dispatching macro:
  325. ;;;                 ;; hash, optional non-negative number, followed by a
  326. ;;;                 ;; non-whitespace character. BTW: LFD is not
  327. ;;;                 ;; whitespace in lisp mode, see (describe-syntax) =>
  328. ;;;                 ;; "LFD                >       which means: endcomment"
  329. ;;;                 (let ((disp-char
  330. ;;;                        (string-to-char
  331. ;;;                         (buffer-substring
  332. ;;;                          (match-beginning 2) (match-end 2)))))
  333. ;;;                   ;; first, clear out the LFD possibility:
  334. ;;;                   (if (= disp-char ?\n) (funcall signaller))
  335. ;;;                   (goto-char
  336. ;;;                    (if (= disp-char ?\()
  337. ;;;                        ;; backup over any "(" so that forward-sexp
  338. ;;;                        ;; will work:
  339. ;;;                        (1- (match-end 0))
  340. ;;;                        (match-end 0)))
  341. ;;;                   (forward-sexp arg)))
  342. ;;;                ((looking-at "#")
  343. ;;;                 ;; any other reader macro syntax is bogus so trap it
  344. ;;;                 ;; before we get a non-informative error message from
  345. ;;;                 ;; Emacs.
  346. ;;;                 (funcall signaller))
  347. ;;;                (t
  348. ;;;                 ;; by default, use GNU Emacs' idea of an sexp
  349. ;;;                 ;; according to the rpc-hm-lisp-mode-syntax-table
  350. ;;;                 ;; defined above.
  351. ;;;                 (forward-sexp arg)))
  352. ;;;       ;; (set-syntax-table stab)
  353. ;;;       (store-match-data omd))))
  354. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  355.  
  356. (defun rpc-hm-parse-ans (&optional ans)
  357.   "Parses up an answer ANS from the remote server on the assumption that
  358.   `(documentation 'enlib:with-errors-and-io-trapped)' conforms to:
  359.        =>
  360.     During the execution of FORMS, errors are trapped, the standard CL
  361.     IO-streams, *standard-input*, *query-io*, *debug-io*, and *terminal-io*,
  362.     are lexically rebound to *dev-null*, a stream that immediately supplies
  363.     EOF on input and discards all output, while output to any of the streams
  364.     *standard-output*, *error-output*, and *trace-output* is trapped and
  365.     returned as a component of the return value produced by the execution of
  366.     this macro.
  367.  
  368.     This macro uses a customized version of the CLtL2 macro
  369.     `with-standard-io-syntax' to set up default, sensible values for
  370.     printing control, so that the reader may be able to re-read the printed
  371.     output. The standard version cannot be used directly here, since in this
  372.     case wee need a more flexible scheme to allow e.g. #<...> objects to be
  373.     transferred back to the client, which should have the ultimate control
  374.     of what to do with the object.
  375.     See with-standard-io-syntax-almost-as-in-cltl2.
  376.  
  377.     The return value is always a list of 3 values:
  378.  
  379.       The first value is T if the evaluation of FORMS did not signal an
  380.     error condition, NIL otherwise.
  381.  
  382.       The second value is the actual value produced by FORMS within an
  383.     implicit PROGN, wrapped into a string with `prin1-to-string' to simplify
  384.     parsing at the client end of a communication channel. If an error was
  385.     signaled during the execution of FORMS, an error message is returned.
  386.     This message is also wrapped by `prin1-to-string' to make unwrapping
  387.     independent of the actual outcome.
  388.  
  389.       The third value returned is a string containing the output to any of
  390.     the standard CLtL2 output streams, *standard-output*, *error-output*,
  391.     and *trace-output*, if any, produced by FORMS.
  392.  
  393.     Note that if the evaluation of FORMS returns multiple values, only the
  394.     first value is preserved by this macro.
  395.  
  396.     Use MULTIPLE-VALUE-LIST or MULTIPLE-VALUE-BIND if you need to retrieve
  397.     multiple-values produced by FORMS.
  398.  
  399.  See also rpc-hm-reparse-ans ()."
  400.   
  401.   (let (eval-ok-p val stdout)
  402.     (save-excursion
  403.       (set-buffer (get-buffer-create " *rpc-hm-reply-parse-buf*"))
  404.       (make-local-variable 'debug-on-error) (setq debug-on-error t)
  405.       (if ans (progn (erase-buffer) (insert ans)))
  406.       (set-syntax-table rpc-hm-lisp-mode-syntax-table)
  407.       (goto-char (point-min))
  408.       (condition-case c
  409.       (progn
  410.         (down-list 1)
  411.         (setq eval-ok-p (buffer-substring (point) (progn (forward-sexp 1) (point))))
  412.         (skip-chars-forward " \t\n")
  413.         (setq val (buffer-substring (point) (progn (forward-sexp 1) (point))))
  414.         (skip-chars-forward " \t\n")
  415.         (setq stdout (buffer-substring (point) (progn (forward-sexp 1) (point))))
  416.         (list eval-ok-p (rpc-hm-read-from-string val) stdout))
  417.     (error
  418. ;;; If anything goes wrong at this point, it means that the server
  419. ;;; returned something unexpected - perhaps there was an error condition
  420. ;;; that couldn't be catched by the innermost
  421. ;;; `with-errors-and-io-trapped'. This is the case with errors that are
  422. ;;; catched by the server during the _parsing_ of incoming requests.
  423. ;;;
  424. ;;; Try e.g. (sys:com-show-herald) on a Symbolics Lispm, and you get:
  425. ;;; 
  426. ;;; "Exporting #:COM-SHOW-HERALD from package SYSTEM would cause name conflict in SYSTEM-INTERNALS.
  427. ;;; While reading from #<STACK-LEXICAL-CLOSURE CLI::STRING-INPUT-STREAM 144160012>"
  428. ;;;
  429. ;;; Actually, this is a server protocol violation, but handle it
  430. ;;; gracefully all the same, by raising a synthetic rpc-hm-network-server-condition.
  431.      (let ((screwy-server-feedback
  432.         (buffer-substring (point-min) (point-max))))
  433.        (if (zerop (length screwy-server-feedback))
  434.            (setq screwy-server-feedback "Client got no reply from server"))
  435.        (list "NIL" screwy-server-feedback "")))))))
  436.  
  437.  
  438. (defun rpc-hm-reparse-ans ()
  439.   "Reparses an answer from the remote server. See rpc-hm-parse-ans ().
  440. Useful for extracting detailed info on remote eval outcome."
  441.   (rpc-hm-parse-ans))
  442.  
  443.  
  444. (defvar rpc-hm-over-tcp-state
  445.   nil
  446.   "A debugging aid to tell the current state of `rpc-hm-over-tcp-process'")
  447.  
  448. (defvar rpc-hm-over-tcp-replystr
  449.   ""
  450.   "Raw reply string from remote server host")
  451.  
  452. (defvar rpc-hm-over-tcp-process nil
  453.   "The RPC HM client TCP process")
  454.  
  455. (defun rpc-hm-over-tcp-sentinel (proc str)
  456.   (ignore proc)
  457.   (setq rpc-hm-over-tcp-state
  458.     (cons (list proc str) rpc-hm-over-tcp-state)))
  459.     
  460. (defun rpc-hm-over-tcp-filter (proc str)
  461.   (ignore proc)
  462.   ;; HOSTNAME, a string, is supposed to have a dynamic binding when this
  463.   ;; filter is activated, but otherwise use the default current host
  464.   ;; instead of just crashing:
  465.   (let ((host-id
  466.      (or (and (boundp 'hostname) hostname)
  467.          (rpc-hm-get-current-host))))
  468.     (setq rpc-hm-over-tcp-replystr
  469.       (concat rpc-hm-over-tcp-replystr
  470.           (ascii-filter
  471.            str ':input
  472.            (rpc-hm-get-host-att host-id 'type))))))
  473.  
  474.       
  475.  
  476. (defun rpc-hm-over-tcp (hostname form &optional invoke-elisp-reader-p)
  477.   "Function to call from other elisp programs. Makes an RPC-HM protocol
  478. request over ip/tcp to HOSTNAME, asking it to evaluate FORM. A non-nil
  479. optional argument INVOKE-ELISP-READER-P invokes the Emacs Lisp Reader on
  480. the results returned, but note that the primitive elisp reader cannot
  481. handle normal Common Lisp reader macros beginning with `#'. Also note
  482. that the Emacs Lisp Reader is case-sensitive.
  483.  
  484. On normal exit it returns the results of the evaluation to the caller as
  485. an elisp object or a string, depending on the value of
  486. INVOKE-ELISP-READER-P.
  487.  
  488. If the evaluation fails, a `rpc-hm-network-server-condition' is signalled with
  489. the corresponding RPC-HM server error message as data to
  490. signal-handlers.
  491.  
  492. If the underlying ip/tcp software fails to establish a connection to
  493. HOSTNAME, a `rpc-hm-network-connection-error' is signalled.
  494.  
  495. All types of error conditions explicitly signalled here can be trapped
  496. by providing a handler for the condition `rpc-hm-network-condition'.
  497. See `condition-case'"
  498.   
  499.   (or (stringp hostname)
  500.       (if (symbolp hostname)
  501.       (setq hostname (symbol-name hostname))
  502.       ;; (signal 'wrong-type-argument (list 'symbolp hostname))
  503.       (error "1st arg, HOSTNAME (%s), is not a symbol or a string"
  504.          hostname)))
  505.   (or (stringp form) (setq form (prin1-to-string form)))
  506.   (setq rpc-hm-over-tcp-process 
  507.     (condition-case c
  508.         (open-network-stream 
  509.          "RPC HM Client over TCP" 
  510.          nil
  511.          hostname
  512.          "rpc-hm")
  513.       (error (signal 'rpc-hm-network-connection-error (cdr c)))))
  514. ;;; /etc/services entry should look similar to this:
  515. ;;; rpc-hm 10801/tcp       # <comment string>
  516. ;;; or you may `play the whale' and just grab a port number and use that
  517. ;;; instead of "rpc-hm" above, but then you shouldn't aspire to be the
  518. ;;; most popular person among the rest of the networking programmers at
  519. ;;; your site.
  520.   
  521.   (let ((ret-vals nil))
  522.     (setq rpc-hm-over-tcp-state nil)
  523.     (setq rpc-hm-over-tcp-replystr "")
  524.     (set-process-sentinel 
  525.      rpc-hm-over-tcp-process 
  526.      (function rpc-hm-over-tcp-sentinel))
  527.     (set-process-filter
  528.      rpc-hm-over-tcp-process
  529.      (function rpc-hm-over-tcp-filter))
  530.     
  531. ;;; From comint.el:
  532. ;;;   (defun bridge-send-string (process string)
  533. ;;;     "Send PROCESS the contents of STRING as input.
  534. ;;;   This is equivalent to process-send-string, except that long input strings
  535. ;;;   are broken up into chunks of size comint-input-chunk-size. Processes
  536. ;;;   are given a chance to output between chunks. This can help prevent processes
  537. ;;;   from hanging when you send them long inputs on some OS's."
  538. ;;;     (let* ((len (length string))
  539. ;;;            (i (min len bridge-chunk-size)))
  540. ;;;       (process-send-string process (substring string 0 i))
  541. ;;;       (while (< i len)
  542. ;;;         (let ((next-i (+ i bridge-chunk-size))) ;512
  543. ;;;           (accept-process-output)
  544. ;;;           (process-send-string process (substring string i (min len next-i)))
  545. ;;;           (setq i next-i)))))
  546. ;;;
  547. ;;; We cannot deliver string args longer than the maximum OS pty buffer
  548. ;;; size:
  549.     (process-send-string
  550.      rpc-hm-over-tcp-process
  551.      (ascii-filter
  552.       (prin1-to-string
  553.        (format "(enlib:with-errors-and-io-trapped %s)" form))
  554.       ':output (rpc-hm-get-host-att hostname 'type)))
  555.  
  556. ;;; This is a minor problem with the RPC-HM protocol since the server side
  557. ;;; is doing a READ-FROM-STRING and hangs either until the input is
  558. ;;; complete, or times out. Symptom: Server side barfs "EOF encountered on
  559. ;;; string-input-stream".
  560. ;;;
  561. ;;; Workaround: Avoid huge arguments. Use filesystem files as a means for
  562. ;;; exchanging large amounts of data between the client and server sides.
  563. ;;; See src/process.c in the GNU Emacs distribution.
  564.     
  565.     (or noninteractive
  566.     (message "Waiting for %s to respond..." hostname))
  567.     (setq rpc-hm-over-tcp-state
  568.       (cons (list 'before (process-status rpc-hm-over-tcp-process))
  569.         rpc-hm-over-tcp-state))
  570.     (while (memq (process-status rpc-hm-over-tcp-process) '(open run))
  571.       ;; - network connections should always return either 'open or
  572.       ;; 'closed, but this doesn't seem to be true for Emacs versions
  573.       ;; prior to 18.58.
  574.       ;; - this test takes advantage of the fact that the RPC-HM
  575.       ;; protocol specifies that the server is supposed to close down
  576.       ;; the connection after the reply has been computed.
  577.       (accept-process-output rpc-hm-over-tcp-process))
  578.     (setq rpc-hm-over-tcp-state
  579.       (cons (list 'after (process-status rpc-hm-over-tcp-process))
  580.         rpc-hm-over-tcp-state))
  581.     (or noninteractive
  582.     (message "Waiting for %s to respond...OK" hostname))
  583.     
  584.     (let (ans)
  585.       (setq 
  586.        ans
  587.        (condition-case c
  588.        (rpc-hm-read-from-string rpc-hm-over-tcp-replystr)
  589.      (error
  590.       (format
  591.        "(NIL \"\\\"%s - see `rpc-hm-over-tcp-replystr'\\\"\" \"\")"
  592.        "Client encountered an unreadable server reply-format"))))
  593. ;;; Perhaps I should introduce yet another condition type, e.g.
  594. ;;; `rpc-hm-network-client-condition' instead, but I think I'll leave
  595. ;;; that to a later version. Right now I doubt that the application
  596. ;;; programmer really needs to distinguish these error conditions, let
  597. ;;; alone treat them differently.
  598.       (setq ret-vals (rpc-hm-parse-ans ans))
  599.       (let ((case-fold-search t))
  600.     (if (string-match "^T$" (elt ret-vals 0))
  601.         ;; Everything is fine:
  602.         (if invoke-elisp-reader-p
  603.         (rpc-hm-read-from-string (elt ret-vals 1))
  604.         (elt ret-vals 1))
  605.         ;; Else the server barfed about something:
  606.         (signal 'rpc-hm-network-server-condition
  607.             ;; Return the error message as data for handlers:
  608.             (list (rpc-hm-read-from-string (elt ret-vals 1)))))))))
  609.  
  610.  
  611.  
  612. (defvar rpc-hm-client-program
  613.   "rpc-hm-client-program"
  614.   "*The Unix RPC/UDP based client program that relays your requests to
  615. the RPC-HM server host using the LISP_SERVICE RPC protocol. Should be
  616. found somewhere along your exec-path.")
  617.  
  618. (defun rpc-hm-over-rpc-udp (hostname form &optional invoke-elisp-reader-p)
  619.   "Function to call from other elisp programs. Makes an RPC-HM protocol
  620. request over RPC/UDP to HOST, asking it to evaluate FORM. A non-nil
  621. optional argument INVOKE-ELISP-READER-P invokes the Emacs Lisp Reader on
  622. the results returned, but note that the primitive elisp reader cannot
  623. handle normal Common Lisp reader macros beginning with `#'. Also note
  624. that the Emacs Lisp Reader is case-sensitive.
  625.  
  626. On normal exit it returns the results of the evaluation to the caller as
  627. an elisp object or a string, depending on the value of
  628. INVOKE-ELISP-READER-P.
  629.  
  630. If the evaluation fails, a `rpc-hm-network-server-condition' is signalled with
  631. the corresponding RPC-HM server error message as data to
  632. signal-handlers.
  633.  
  634. If the the underlying RPC/UDP software fails to establish a connection to
  635. HOST, a `rpc-hm-network-connection-error' is signalled.
  636.  
  637. All types of error conditions explicitly signalled here can be trapped
  638. by providing a handler for the condition `rpc-hm-network-condition'.
  639. See `condition-case'"
  640.   
  641.   (or (stringp hostname)
  642.       (if (symbolp hostname)
  643.       (setq hostname (symbol-name hostname))
  644.       ;; (signal 'wrong-type-argument (list 'symbolp hostname))
  645.       (error "1st arg, HOSTNAME (%s), is not a symbol or a string"
  646.          hostname)))
  647.   (or (stringp form) (setq form (prin1-to-string form)))
  648.   
  649.   (let ((ret-vals nil) buf-mark-1 buf-mark-2
  650.     (client-error-p nil))
  651.     (save-excursion
  652.       (set-buffer (get-buffer-create " *rpc-hm-unix-rpc-udp-buf*"))
  653.       (make-local-variable 'debug-on-error) (setq debug-on-error t)
  654.       (erase-buffer)
  655.       (goto-char (point-min))
  656.       (setq buf-mark-1 (point))
  657.       (insert
  658.        (format "(enlib:with-errors-and-io-trapped %s)" form))
  659.       (setq buf-mark-2 (point))
  660.       (condition-case c
  661.       (call-process-region
  662.        buf-mark-1
  663.        buf-mark-2
  664.        rpc-hm-client-program
  665.        nil                ;don't delete src input
  666.        t                ;output to current buffer
  667.        nil                ;don't redisplay buffer during
  668.                     ;output 
  669.        hostname            ;prog arg: name of RPC server
  670.                     ;host
  671.        )
  672.     (error (setq client-error-p t)
  673.            (setq ret-vals (cdr c))))
  674.       (save-excursion            ;remove "\nEOF\n":
  675.     (forward-word -1)        ;go back 1 word
  676.     (if (looking-at "^EOF\n")
  677.         (progn (delete-char -1 nil) (delete-char 4 nil))
  678.         ;; Else something went seriously wrong.
  679.         (setq client-error-p t)))
  680.       
  681.       (or ret-vals
  682.       (setq ret-vals
  683.         (buffer-substring buf-mark-2 (point)))))
  684.     
  685.     (if client-error-p
  686.     (signal 'rpc-hm-network-connection-error (list ret-vals)))
  687.     
  688.     (setq ret-vals (rpc-hm-parse-ans ret-vals))
  689.     (let ((case-fold-search t))
  690.       (if (string-match "^T$" (elt ret-vals 0))
  691.       ;; Everything is fine:
  692.       (if invoke-elisp-reader-p
  693.           (rpc-hm-read-from-string (elt ret-vals 1))
  694.           (elt ret-vals 1))
  695.       ;; Else the server barfed about something:
  696.       (signal 'rpc-hm-network-server-condition
  697.           ;; Return the error message as data for handlers:
  698.           (list (rpc-hm-read-from-string (elt ret-vals 1))))))))
  699.  
  700.  
  701. (defun rpc-hm-internal (host form invoke-elisp-reader-p
  702.                  transport-protocol)
  703.   "Direct an RPC-HM protocol request to HOST asking it to evalute FORM.
  704. HOST should be a symbol that names a computer that is hosting an RPC-HM
  705. server, or it could be the keyword :any, indicating that any such host
  706. will do, in which case the rpc-hm-host-db is used to pick one.
  707.  
  708. Third arg INVOKE-ELISP-READER-P if non-nil invokes the Emacs Lisp
  709. reader on the returned result. Fourth arg TRANSPORT-PROTOCOL is either
  710. the name of a transport medium, such as :ip-tcp or :rpc-udp, or the
  711. keyword :any, indicating that any trasport medium will do.
  712.  
  713. See the documentation for `rpc-hm-over-tcp' and `rpc-hm-over-rpc-udp'
  714. for a more detailed description of the underlying functions."
  715.   
  716.   (cond ((eq host ':any)
  717.      (rpc-hm-internal-any-host
  718.       form invoke-elisp-reader-p transport-protocol))
  719.     ((eq transport-protocol ':any)
  720.      (rpc-hm-internal-any-medium
  721.       host form invoke-elisp-reader-p))
  722.     (t
  723.      (cond ((eq transport-protocol ':ip-tcp)
  724.         (rpc-hm-over-tcp host form invoke-elisp-reader-p))
  725.            ((eq transport-protocol ':rpc-udp)
  726.         (rpc-hm-over-rpc-udp host form invoke-elisp-reader-p))
  727.            (t (error "No such transport %s." transport-protocol))))))
  728.  
  729.  
  730. (defun rpc-hm-internal-any-host (form invoke-elisp-reader-p transport-protocol)
  731.   (catch 'rpc-hm-success
  732.     (let ((hosts-tried nil)
  733.       (host (rpc-hm-get-current-host)))
  734.       (while (not (memq host hosts-tried))
  735.     (condition-case c
  736.         (throw 'rpc-hm-success
  737.            (rpc-hm-internal host form invoke-elisp-reader-p
  738.                     transport-protocol))
  739.       (rpc-hm-network-connection-error
  740.        (setq hosts-tried (cons host hosts-tried))
  741.        (setq host (rpc-hm-next-host)))))
  742.       (signal
  743.        'rpc-hm-network-connection-error
  744.        (list
  745.     (format
  746.      "All server hosts in rpc-hm-host-db (%s) tried, %s"
  747.      (mapconcat (function identity)
  748.             (mapcar (function (lambda (el) (symbol-name el)))
  749.                 hosts-tried)
  750.             ", ")
  751.      "but none responded to a connection request."))))))
  752.       
  753.     
  754.  
  755. (defun rpc-hm-internal-any-medium (host form invoke-elisp-reader-p)
  756.   (catch 'rpc-hm-success
  757.     (let ((media-tried nil)
  758.       (medium (elt (rpc-hm-get-host-att host 'rpc-hm-support)
  759.                (rpc-hm-get-host-att host 'current-medium-ix))))
  760.       (while (not (memq medium media-tried))
  761.     (condition-case c
  762.         (throw 'rpc-hm-success
  763.            (rpc-hm-internal
  764.             host form invoke-elisp-reader-p medium))
  765.       (rpc-hm-network-connection-error
  766.        (setq media-tried (cons medium media-tried))
  767.        (setq medium (rpc-hm-next-medium host)))))
  768.       (signal 
  769.        'rpc-hm-network-connection-error
  770.        (list
  771.     (format
  772.      "All media supported by host %s %s (%s) tried, but none%s"
  773.      host
  774.      "listed in rpc-hm-host-db"
  775.      (mapconcat (function identity)
  776.             (mapcar (function (lambda (el) (symbol-name el)))
  777.                 media-tried)
  778.             ", ")
  779.      " could provide transport for the RPC-HM protocol."))))))
  780.