1 ;;; ***********************************************************
  2 ;;; *                                                         *
  3 ;;; * Copyright, (C) Honeywell Information Systems Inc., 1982 *
  4 ;;; *                                                         *
  5 ;;; * Copyright (c) 1978 by Massachusetts Institute of        *
  6 ;;; * Technology and Honeywell Information Systems, Inc.      *
  7 ;;; *                                                         *
  8 ;;; ***********************************************************
  9 ;;;
 10 ;;;
 11 ;;;       Interactive Message Handling for Multics EMACS
 12 ;;;
 13 ;;;       Coded in a peek of phit 1978.08.07-11
 14 ;;;                               by Richard S. Lamson
 15 ;;;       Patterned after similar code by bsg.
 16 ;;;       Qsends by bsg, 4/15/79, to enable better communications
 17 ;;;          with persons at MIT-AI.
 18 ;;;
 19 ;;;       Extensively re-written 10-23 January 1980 by Richard Mark Soley
 20 ;;;       to allow multiple mailboxes, automatic checking for qsend-ok-flag,
 21 ;;;       really use emacs interrupt system, and clean up this nasty code.
 22 ;;;
 23 ;;;       Modified 7 February 1980 by Richard Mark Soley to create
 24 ;;;       'fill-messages option; i.e., whether or not to fill messages.
 25 ;;;
 26 ;;;       Modified 1 March 1980 by R. M. Soley to add hook, take away
 27 ;;;       auto check on qsend-ok (sniffle - it doesn't really work), fix
 28 ;;;       bug in filling messages, add short-message-accept option.
 29 ;;;
 30 ;;;       Modified 15 March 1980 for repeat-last-message and send-a-message.
 31 ;;;       repeat-last-message: locally display last message sent to you.
 32 ;;;       send-a-message: prompts for name/message, sends to any random,
 33 ;;;       creating message buffer etc.  (by Soley)
 34 ;;;
 35 ;;;       All of Soley's improvements integrated/installed 10/4/80 by BSG
 36 ;;;
 37 ;;;       Modified 19 January 1984 - Barmar - to comment out register-option
 38 ;;;       forms, as they were moved to e_option_defaults_.
 39 ;;;
 40 ;;;       Modified 31 July 1984 - K. P. Fleming - quick fix to use new message
 41 ;;;       facility (will be rewritten later).
 42 ;;;       Modified 5 October 1984 - B. Margolin - quick fixes to KPF's fixes.
 43 
 44 (%include e-macros)
 45 (declare (special known-buflist accept-messages-environment-initp)
 46          (*lexpr expand-pathname-relative))
 47 (declare (*expr absolute_pathname_ e_lap_$rtrim display-com-error
 48                 exch-point-mark expand_pathname_ runoff-fill-region
 49                 set-emacs-interrupt-handler user_info_$homedir
 50                 trim-minibuffer-response e_pl1_$retrieve_olc_message))
 51 (defvar message-mode-hook nil)
 52 (remprop 'accept-messages 'autoload)
 53 
 54 (declare (defpl1 e_pl1_$set_message_cleanup "")
 55          (defpl1 user_info_$whoami ""
 56                  (return char (32.))
 57                  (return char (32.)))
 58          (defpl1 e_pl1_$set_message_handler ""
 59                  (char (*))
 60                  (fixed bin(17.))
 61                  (return fixed bin(35.)))
 62          (defpl1 e_pl1_$retrieve_message ""
 63                  (return char (64.) varying)
 64                  (return char (32.) varying)
 65                  (return char (2000.) varying))
 66          (defpl1 e_pl1_$send_message ""
 67                  (char (*))
 68                  (char (*))
 69                  (char (*))
 70                  (return fixed binary (35.)))
 71          (defpl1 host_id_$check_id ""
 72                  (char (*))
 73                  (bit (36.))
 74                  (bit (36.))
 75                  (return fixed bin (32.))
 76                  (return fixed bin (35.)))
 77          (defpl1 host_id_$symbol ""
 78                  (fixed bin (32.))
 79                  (return char (32.))
 80                  (return fixed bin (35.)))
 81          (defpl1 qsend$qsend ""
 82                  (char (*))
 83                  (char (*))
 84                  (char (*)))
 85          (defpl1 absolute_pathname_$add_suffix ""
 86                  (char (*))
 87                  (char (*))
 88                  (return char (168.))
 89                  (return fixed bin (35.)))
 90          (special current-buffer current-buffer-mode conversations
 91                   last-message-sender-display-variable
 92                   tty-no-upmotionp last-message-sender last-message-time
 93                   last-message-mark last-message-error-code fill-prefix
 94                   short-message-accept message-hook last-message
 95                   qsend-ok-flag daemon-mbx-dir fill-messages))
 96 ;;;^L
 97 
 98 (setq qsend-ok-flag nil                           ;the default
 99       daemon-mbx-dir ">user_dir_dir>Daemon>mailboxes"
100       conversations nil
101       last-message "No last message."
102       last-message-sender nil)
103 
104 ;;; What do these options MEAN??? Well...
105 ;;;
106 ;;; If short-message-accept is t, messages will not be put on the
107 ;;; screen in local display; a message of the form "Messages recieved from
108 ;;; Foo.BAR" will appear under the mode line instead.  The default is nil.
109 ;;;
110 ;;; If fill-messages is nil, messages will NOT be filled with
111 ;;; runoff-fill-region.  The default is nil (NOT to fill).
112 ;;;
113 ;;; If message-hook is non-null, it will be funcalled with the following
114 ;;; arguments: sender, time, message, mailbox message was received in.
115 ;;; (The last item will be nil if the message was received in the
116 ;;; default mbx).  There is more to it, though, so be careful.  If the
117 ;;; called function returns nil, NO OTHER ACTION WILL BE PERFORMED ON THE
118 ;;; MESSAGE.  So, if you want it in the buffer or somesuch, do it yourself
119 ;;; of call the routine below that does it.
120 
121 ;;; (register-option 'short-message-accept nil)   ;default is long ;moved to e_option_defaults_
122 ;;; (register-option 'fill-messages nil)                    ;default is to not fill ;moved to e_option_defaults_
123 ;;; (register-option 'message-hook nil)           ;default is normal acceptor ;moved to e_option_defaults_
124 
125 (defun accept-messages-make-sense-of-mbxname (mbx)
126        (let ((dots (am-find-chars mbx "."))
127              (greaters (am-find-chars mbx ">")))
128             (let ((inter (cond ((memq 1 greaters) mbx)
129                                ((or (> 0 (length greaters))
130                                     (not (= 0 (index mbx "<"))))
131                                 (expand-pathname-relative mbx
132                                                           "working_dir"))
133                                ((= 0 (length dots))
134                                 (catenate daemon-mbx-dir ">" mbx))
135                                ((samepnamep (substr mbx
136                                                     (- (stringlength mbx)
137                                                        3))
138                                             ".mbx")
139                                 (expand-pathname-relative mbx "home_dir"))
140                                ((> (length dots) 0)
141                                 (let ((Name (substr mbx 1 (1- (car dots))))
142                                       (Project
143                                         (substr mbx (1+ (car dots)))))
144                                      (catenate ">user_dir_dir>"
145                                                Project
146                                                ">"
147                                                Name
148                                                ">"
149                                                Name)))
150                                (t nil))))
151                  (cond ((null inter) nil)
152                        (t (let ((answer
153                                   (e_lap_$trim
154                                     (car
155                                       (absolute_pathname_$add_suffix
156                                         inter
157                                         "mbx")))))
158                                (substr answer
159                                        1
160                                        (- (stringlength answer) 4))))))))
161 
162 (defun am-find-chars (string char)
163        (am-find-chars_guts string char 0))
164 
165 (defun am-find-chars_guts (string char before)
166        (let ((where (index string char)))
167               (cond ((= 0 where) nil)
168                       (t (cons (+ before where)
169                                  (am-find-chars_guts (substr string (1+ where))
170                                                          char
171                                                          where))))))
172 
173 (defun accept-messages-environment ()
174        (cond ((or (not (boundp 'accept-messages-environment-initp))
175                   (not accept-messages-environment-initp))
176               (e_pl1_$set_message_cleanup)
177               (set-perm-key '^X: 'message-response-command)
178               (set-perm-key '^X/' 'go-to-new-message-buffer)
179               (set-perm-key '^X/` 'send-a-message)
180               (set-perm-key '^X/~ 'repeat-last-message)
181               (setq accept-messages-environment-initp t))))
182 
183 (defun accept-messages n
184        (cond ((= n 0) (accept-messages-default-mbx))
185              (t (mapc 'accept-messages-path (listify n)))))
186 
187 (defprop accept-msgs accept-messages expr)
188 
189 ;;; Accept messages on a certain path.
190 
191 (defun accept-messages-path (message-pathname)
192        (let ((pathname-of-mbx
193                (accept-messages-make-sense-of-mbxname message-pathname)))
194             (and (null pathname-of-mbx)
195                  (display-error (catenate
196                                   "Invalid mailbox pathname: "
197                                   message-pathname)))
198             (accept-messages-environment)
199             (let ((error-code
200                     (e_pl1_$set_message_handler
201                       pathname-of-mbx (set-emacs-interrupt-handler
202                                         'console-messages-interrupt-handler
203                                         pathname-of-mbx))))
204                  (or (= 0 error-code)
205                      (display-com-error error-code
206                                         (catenate "While accepting messages on "
207                                                   pathname-of-mbx))))))
208 
209 
210 ;;; Accept messages on default mbx.
211 
212 (defun accept-messages-default-mbx ()
213        (accept-messages-environment)
214        (let ((pathname-of-mbx
215                (let ((id (user_info_$whoami)))
216                     (let ((proj (e_lap_$rtrim (second id)))
217                           (pers (e_lap_$rtrim (first id))))
218                          (catenate ">udd>" proj ">" pers ">" pers)))))
219             (let ((error-code
220                     (e_pl1_$set_message_handler
221                       pathname-of-mbx
222                       (set-emacs-interrupt-handler
223                         'console-message-interrupt-handler nil))))
224                  (or (= 0 error-code)
225                      (display-com-error error-code "While accepting messages."
226                                         )))))
227 
228 
229 ;;; Lisp side of OLC stuff -- see e_pl1_ olc stuff.
230 ;;;       RMSoley 10 April 1980
231 
232 (declare (defpl1 olcn$olcn2 "" (char (*)) (char (*)))
233          (special olc-messages))
234 
235 ;;;(register-option 'olc-messages nil)
236 (defvar olc-messages nil)                         ;made invis. option BSG 10/11/80
237 (defvar keep-unresponded-buffers-modified nil)
238 
239 (defun console-message-interrupt-handler (intno mbx arg)
240        intno                                      ; compiler gets bummed
241                                                   ; out otherwise
242        (do-forever
243            (setq arg (e_pl1_$retrieve_message))
244            (and (= 0 (stringlength (car arg)))
245                 (return nil))
246            (console-message-processor (car arg)
247                                       (cadr arg)
248                                       (caddr arg)
249                                       mbx))
250        (and olc-messages
251             (do-forever
252                 (setq arg (e_pl1_$retrieve_olc_message))
253                 (and (= 0 (stringlength (car arg)))
254                      (return nil))
255                 (console-message-processor (car arg)
256                                            (cadr arg)
257                                            (caddr arg)
258                                            'OLC))))
259 
260 (defun console-message-processor (sender time message mbx)
261        (let ((msender (massage-message-sender sender)))
262             (setq last-message-sender-display-variable
263                   (get-message-sender-display sender))
264             (cond ((or (null message-hook)
265                        (and message-hook
266                             (funcall message-hook msender time message mbx)))
267                    (or (cnsmsg-make-qsend-sense msender time message mbx)
268                        (cnsmsg-make-mail-sense msender time message mbx)
269                        (process-the-message msender time message mbx))))))
270 
271 (defun process-the-message (msender time message mbx)
272        (ring-tty-bell)
273        (setq last-message message)
274        (let ((buffer-in-progress current-buffer))
275             (save-excursion-buffer
276               (go-to-or-create-message-buffer msender)
277               (let ((display-time
278                       (massage-message-time time last-message-time)))
279                    (insert-message-into-message-buffer display-time
280                                                        time
281                                                        message
282                                                        mbx)
283                    (cond ((or tty-no-upmotionp
284                               (buffer-on-display-in-window current-buffer)
285                               (eq buffer-in-progress current-buffer)))
286                          (short-message-accept
287                            (minibuffer-print "Message received from "
288                                              msender
289                                              "."))
290                          (t (local-display-message display-time
291                                                    message
292                                                    mbx)))))))
293 
294 (defun local-display-message (time message mbx)
295        (init-local-displays)
296        (setq last-message-sender-display-variable
297              (get-message-sender-display last-message-sender))
298        (let ((display-time (cond ((< (stringlength time) 4) ":")
299                                  (t (catenate " (" time "):")))))
300             (local-display-generator-nnl
301               (catenate "Message from " last-message-sender-display-variable
302                         display-time))
303             (cond ((null mbx))
304                   (t (local-display-generator-nnl
305                        (catenate "(Received in mailbox " mbx ")"))))
306             (local-display-generator-nnl message))
307        (end-local-displays))
308 
309 (defun insert-message-into-message-buffer (display-time time message mbx)
310        (without-modifying
311          (go-to-mark last-message-mark)
312          (set-the-mark)
313          (insert-string display-time)
314          (insert-string ": ")
315          (insert-string message)
316          (if fill-messages
317              (let ((fill-prefix "   "))
318                   (without-saving (runoff-fill-region)))
319              (without-saving (runoff-fill-region)))
320          (new-line)
321          (if (not (null mbx))
322              (insert-string "(Rec'd. in mbx. ")
323              (insert-string mbx)
324              (insert-string ")")
325              (new-line)))
326        (putprop current-buffer "<=" 'message-direction)     ;reply necessary
327        (if keep-unresponded-buffers-modified
328            (setq buffer-modified-flag t))
329        (set-mark-here last-message-mark)
330        (go-to-end-of-buffer)
331        (setq last-message-time time))
332 
333 (defun cnsmsg-make-mail-sense (msender time message mbx)
334        time                   ;; goddam lcp
335        (cond ((samepnamep (substr message 1 (stringlength "You have mail"))
336                           "You have mail")
337               (ring-tty-bell)
338               (minibuffer-print "You have mail from "
339                                 msender
340                                 (cond (mbx (catenate " in mailbox " mbx))
341                                       (t ""))
342                                 ".")
343               t)
344              (t nil)))
345 
346 ;;;^L
347 
348 ;;;
349 ;;;       Character munching functions for message beastie.
350 ;;;
351 
352 (defun massage-message-sender (sender)    ; remove "(from) at system_high"
353        (setq sender (massage-message-sender1 sender " ("))
354        (setq sender (massage-message-sender1 sender " at")))
355 
356 (defun massage-message-sender1 (sender string-to-look-for)  ; aux function
357        (prog (position)
358              (or (= 0 (setq position (index sender string-to-look-for)))
359                  (setq sender (substr sender 1 (1- position))))
360              (return sender)))
361 
362 (defun massage-message-time (new-time old-time)   ; make shortest unambiguous
363                                                   ; time string
364        (prog (date-string)
365              (cond ((samepnamep (substr new-time 1 14.)
366                                 (substr old-time 1 14.))
367                     (return "="))
368                    (t (cond ((samepnamep (substr new-time 1 8.)
369                                          (substr old-time 1 8.))
370                              (setq date-string ""))
371                             (t (setq date-string (substr new-time 1 9.))))))
372              (return (catenate date-string (substr new-time 11. 4)))))
373 
374 (defun get-message-sender-display (sender)
375        (let ((lparen-pos (index sender "(")))
376             (let ((rparen-pos (index (substr sender lparen-pos) ")")))
377                  (if (zerop (* lparen-pos rparen-pos))
378                      (massage-message-sender1 sender ".")
379                      else (catenate (substr sender (1+ lparen-pos)
380                                             (- rparen-pos 2))
381                                     " (" (massage-message-sender1 sender ".")
382                                     ")")))))
383 ^L
384 ;;;
385 ;;; Create message buffer, based on the name of the sender of the message.
386 ;;;
387 
388 (defun go-to-or-create-message-buffer (sender)
389        (prog (person project qspr)
390              (and (setq qspr (cnsmsg-qsend-parse-to sender))
391                  (let ((hidr (host_id_$check_id (cadr qspr) 0 0)))
392                       (cond ((= 0 (cadr hidr))
393                              (putprop
394                                (setq sender (car qspr))
395                                (e_lap_$trim (car (host_id_$symbol (car hidr))))
396                                'net-site))
397                             (t
398                                (display-com-error (cadr hidr) (cadr qspr))))))
399              (cond ((setq project
400                           (get (setq person (make_atom sender)) 'net-site))
401                     (setq project (cons 'net-host project)))
402                    (t (setq person (massage-message-sender1 sender "."))
403                       (or (= (stringlength person) (stringlength sender))
404                           (setq project
405                                 (substr sender
406                                         (+ 2 (stringlength person)))))))
407              (go-to-or-create-buffer
408                (implode (append (explodec "Messages from ")
409                                 (explodec person))))
410              (setq last-message-sender person)
411              (go-to-end-of-buffer)
412              (cond ((empty-buffer-p current-buffer)  ;S.O.B.  may have killed
413                                                   ; the buffer, eh!?
414                  (cond ((not project)
415                         (display-error-noabort
416                           "User name must include project. "
417                           sender)
418                         (return nil)))
419                  (putprop current-buffer person 'message-person)
420                  (putprop current-buffer project 'message-project)
421                  (putprop current-buffer "" 'message-direction)
422                  (register-local-var 'last-message-time)
423                  (register-local-var 'last-message-error-code)
424                  (register-local-var 'last-message-mark)
425                  (setq last-message-time "01/01/01  0000.0 GMT Tue"
426                        last-message-error-code 0)
427                  (setq conversations (cons last-message-sender conversations))
428                  (setq current-buffer-mode 'Message)
429                  (set-key 'CR 'respond-from-buffer)
430                  (without-modifying
431                    (insert-string current-buffer)
432                    (insert-string ":")
433                    (new-line)
434                    (new-line))
435                  (setq last-message-mark (set-mark))
436                  (and message-mode-hook (funcall message-mode-hook))))
437              (return t)))
438 
439 (defun message-buffer-prompter ()
440        (let ((completion-list conversations))
441             (let ((ans (trim-minibuffer-response
442                          (cond (last-message-sender
443                                  (catenate "Messages to/from ("
444                                            last-message-sender "): "))
445                                ('else "Messages to/from: "))
446                          NL)))
447                  (cond ((not (nullstringp ans)) ans)
448                        (last-message-sender last-message-sender)
449                        ('else (display-error "No message buffers."))))))
450 
451 ;;; ^X-' -- prompt for message buffer name.
452 (defun go-to-new-message-buffer ()
453        (cond (numarg
454                (list-message-buffers))
455              (t
456                (let ((message-name (message-buffer-prompter))
457                      (prev current-buffer))
458                     (go-to-or-create-message-buffer message-name)
459                     (select-buffer-window current-buffer 4)
460                     (setq previous-buffer prev)))))
461 
462 (defun list-message-buffers ()
463        (let ((msg-buffers-info nil)
464              (original-buffer current-buffer)
465              (previous-buffer previous-buffer))
466             (mapc
467               (function
468                 (lambda (bufname)
469                         (go-to-buffer bufname)
470                         (cond ((eq current-buffer-mode 'Message)
471                                (setq msg-buffers-info
472                                      (cons (list (get bufname 'message-person)
473                                                  (get bufname 'message-direction)
474                                                  (get bufname 'message-project))
475                                            msg-buffers-info))))))
476               known-buflist)
477             (go-to-or-create-buffer original-buffer)
478             (and (null msg-buffers-info)
479                  (display-error "No message buffers."))
480             (init-local-displays)
481             (mapc 'local-display-generator-nnl
482                   '("Listing of Current Message Buffers"
483                      ""
484                      "Direction         Person"
485                      ""))
486             (mapc '(lambda (info)
487                            (local-display-generator-nnl
488                              (catenate
489                                "    "
490                                (cadr info)
491                                TAB
492                                TAB
493                                (car info)
494                                (cond ((atom (caddr info))
495                                       (catenate "." (caddr info)))
496                                      (t ""))
497                                (cond ((let ((site
498                                               (get (make_atom (car info)) 'net-site)))
499                                            (and site (catenate " @ " site))))
500                                      (t "")))))
501                   msg-buffers-info)
502             (local-display-generator-nnl "")
503             (end-local-displays)))
504 
505 
506 ;;;^L
507 
508 ;;;
509 ;;;       Message sending commands.
510 ;;;        Send line in message buffer to other end of conversation.
511 ;;;
512 
513 (defun respond-from-buffer ()                     ; ^M in Message mode.
514        (prog (error-code)
515              (cond ((not (atom (get current-buffer 'message-project)))
516                     (cnsmsg-qsend (cdr (get current-buffer 'message-project))
517                                   (get current-buffer 'message-person)
518                                   (curline-as-string-nnl))
519                     (go send-done)))
520              (cond ((= last-message-error-code
521                        (setq error-code
522                              (e_pl1_$send_message (get current-buffer 'message-person)
523                                             (get current-buffer 'message-project)
524                                             (curline-as-string-nnl)))))
525                    (t
526                      (setq last-message-error-code error-code)
527                      (cond ((= 0 error-code)
528                             (display-error-noabort
529                               "Message sent successfully to "
530                               (get current-buffer 'message-person)
531                               "."
532                               (get current-buffer 'message-project)))
533                            (t
534                              (display-com-error-noabort
535                                error-code
536                                (get current-buffer 'message-person)
537                                "."
538                                (get current-buffer 'message-project))))))
539              send-done)
540        (without-modifying
541          (set-the-mark)
542          (go-to-beginning-of-line)
543          (insert-string "Reply: ")
544          (exch-point-mark der-wahrer-mark)
545          (and fill-messages ((lambda (fill-prefix)
546                                      (setq fill-prefix fill-prefix)
547                                      (without-saving (runoff-fill-region)))
548                              "-> ")))
549        (new-line)
550        (putprop current-buffer "=>" 'message-direction)
551        (set-mark-here last-message-mark)
552        (setq buffer-modified-flag nil))           ; rather than fighting it.
553 
554 (defun message-response-command ()                ; ^X: strikes again.
555        (cond (numarg
556                (cond (last-message-sender
557                        (go-to-or-create-message-buffer last-message-sender))
558                      (t
559                        (display-error "No message buffers."))))
560              (t
561                (cond (last-message-sender
562                        ((lambda (message)
563                                 (save-excursion-buffer
564                                   (cond ((not (= 0 (stringlength message)))
565                                          (go-to-or-create-message-buffer
566                                            last-message-sender)
567                                          (go-to-mark last-message-mark)
568                                          (without-modifying
569                                            (insert-string message)
570                                            (new-line)
571                                            (backward-char))
572                                          (respond-from-buffer)))))
573                         (minibuf-response
574                           (catenate "To " last-message-sender ": ") NL)))
575                      (t
576                        (display-error "No one to respond to."))))))
577 
578 (defun curline-as-string-nnl ()                   ; remove extra newline 'cause
579        ((lambda (str)                             ; send_message won't.
580                 (substr str 1 (1- (stringlength str))))
581         (curline-as-string)))
582 
583 ;;;^L
584 ;;;
585 ;;;       Qsend cruft 4/15/79
586 ;;;
587 
588 (defun cnsmsg-make-qsend-sense (sender time msg mbx)
589        (prog (tox hdr)
590              (or (samepnamep
591                    (substr sender 1 (stringlength "Network_Server"))
592                    "Network_Server")
593                  (return nil))
594              (cond ((samepnamep (substr msg 1 (stringlength "You have mail"))
595                                 "You have mail")
596                     (ring-tty-bell)
597                     (display-error-noabort "You have network mail.")
598                     (return t)))                  ;Don't process any further.
599              (setq tox (index msg "To:"))
600              (cond ((= tox 0)
601                     (setq tox (index msg "to:"))
602                     (cond ((= tox 0)
603                            (setq tox (index msg "TO:"))
604                            (and (= tox 0)
605                                 (return nil)))))) ;no sense made.
606              (setq hdr (e_lap_$trim (substr msg 1 (1- tox)))
607                    msg (substr msg tox))
608              (and (member (substr hdr 1 5) '("From:" "FROM:" "from:"))
609                   (setq hdr (e_lap_$trim (substr hdr 6))))
610              (setq hdr (cnsmsg-qsend-parse-to hdr))
611              (or hdr (return nil))
612              (console-message-processor (car hdr) time msg mbx)
613              (return t)))
614 
615 (defun qsend-ok () (setq qsend-ok-flag t))
616 
617 (defun cnsmsg-qsend (host person msg)
618        (if (not qsend-ok-flag)
619            (display-error "You have not the right to send interactive net mail."))
620        (minibuffer-print "Qsending to " person " at " host ".")
621        (qsend$qsend host person msg)
622        (minibuffer-clear))
623 
624 (defun cnsmsg-qsend-parse-to (x)
625        (prog (sender site tox)
626              (or (= 0 (index x TAB))
627                  (setq x (maknam
628                            (mapcar '(lambda (y)(cond ((= y 11) 40)(t y))) x))))
629              (setq tox (index x "@"))
630              (cond ((> tox 0)
631                     (setq sender (e_lap_$trim (substr x 1 (1- tox)))
632                           x (e_lap_$trim (substr x (1+ tox)))))
633                    (t
634                      (setq tox (index x " at "))
635                      (and (= tox 0)(setq tox (index x " AT ")))
636                      (and (= tox 0)(setq tox (index x " At ")))
637                      (and (= tox 0)(setq tox (index x " -at")))
638                      (and (= tox 0)(return nil))
639                      (setq sender (e_lap_$trim (substr x 1 (1- tox)))
640                            x (e_lap_$trim (substr x (+ tox 4))))))
641              (setq tox (index x " "))
642              (and (= tox 0)(setq tox (1+ (stringlength x))))
643              (setq site (substr x 1 (1- tox)))
644              (setq site (make_atom site) sender (make_atom sender))
645              (putprop sender site 'net-site)
646              (return (list sender site))))
647 
648 ;;;^L
649 ;;; More additions!!!
650 ;;;
651 
652 (defcom repeat-last-message
653         &doc "Repeats via local display the last message received."
654         (and (null last-message-sender)
655              (display-error "No last message."))
656         (local-display-message last-message-time
657                                last-message
658                                nil))
659 
660 (defcom send-a-message
661         &doc "Prompts for a name and message, and sets up a message
662 buffer for that recipient and sends the message without leaving the
663 current buffer."
664         (save-excursion-buffer
665           (and (eq (go-to-new-message-buffer) 'couldnt-get-it)
666                (command-quit))
667           (insert-string
668             (minibuf-response (catenate "To "
669                                         (get current-buffer 'message-person)
670                                         ": ")
671                               NL))
672           (respond-from-buffer)))
673 
674 (defun message-sender-internal (to message)
675        (save-excursion-buffer
676          (cond ((not (= 0 (stringlength message)))
677                 (go-to-or-create-message-buffer to)
678                 (go-to-mark last-message-mark)
679                 (without-modifying
680                   (insert-string message)
681                   (new-line)
682                   (backward-char))
683                 (respond-from-buffer)))))
684 
685 
686 
687 ^L
688 ;;;
689 ;;; Soley's pathname hack .. at sometime, may make standard, but
690 ;;; for now, leave in console-messages.... -BSG
691 ;;;
692 
693 
694 ;;; Pathname expander for start up emacs
695 ;;;       RMSoley 10 January 1980
696 ;;;                5 March   1980 to lexprize epr, add default_working_dir key
697 ;;;               13 March   1980 for zero arguments to epr (path = ""),
698 ;;;                                remove non-working dwdir (since dwd doesn't
699 ;;;                                return right thing)
700 ;;;
701 
702 ;;; expand-pathname-relative is a way to expand a path relative to anywhere
703 ;;; A bit better than e_pl1_$pathname_util, since it accepts "<foo".
704 ;;; Basically hands back a pathname equal to 'path relative to 'relative,
705 ;;; unless relative is one of the following keys:
706 
707 ;;;       nil, "", or "working_dir" . . . expand relative to working dir
708 ;;;       "home_dir"  . . . . . . . . . . expand relative to home dir
709 ;;;       "process_dir" . . . . . . . . . expand relative to process dir
710 
711 ;;; If path begins with a >, relative is ignored (path taken to be absolute)
712 ;;; If relative is missing, assumes working directory
713 ;;; If path & relative are both missing, returns wdir.
714 ;;; If path = "" and relative is non-null, returns the directory without
715 ;;;       a trailing ">"
716 
717 (defun expand-pathname-relative lexpr
718        (and (> lexpr 2)
719             (display-error
720               "expand-pathname-relative: "
721               "Wrong number of arguments supplied."))
722        (let ((path (cond ((< lexpr 1) "")
723                          (t (arg 1))))
724              (relative (cond ((< lexpr 2) nil)
725                              (t (arg 2)))))
726             (and (not (= 0 (caddr (expand_pathname_ relative))))
727                  (display-error
728                    "expand-pathname-relative: Error in syntax of relative."))
729             (and (not (= 0 (caddr (expand_pathname_ path))))
730                  (display-error
731                    "expand-pathname-relative: Error in syntax of pathname."))
732             (let ((rel (e_lap_$rtrim
733                          (cond ((null relative) (absolute_pathname_ ""))
734                                ((nullstringp relative) (absolute_pathname_ ""))
735                                ((samepnamep relative "working_dir")
736                                 (absolute_pathname_ ""))
737                                ((samepnamep relative "home_dir")
738                                 (user_info_$homedir))  ;used user_info BSG 10/4/80
739                                ((samepnamep relative "process_dir")
740                                 process-dir)      ;used vbl BSG 10/4/80
741                                (t (expand-pathname-relative relative
742                                                             "working_dir"))))))
743                  (cond ((samepnamep (substr path 1 1) ">") path) ;absolute
744                        ((= lexpr 0) rel)          ;return wdir
745                        ((null path) rel)
746                        ((nullstringp path) rel)
747                        (t (expand-pathname-fix-ups
748                             (catenate rel         ;really expand
749                                       ">"
750                                       path)))))))
751 
752 ;;; The guts.  Takes care of those nasty less thans.
753 ;;; ">udd>foo<bar" and ">udd>foo><bar" both => ">udd>bar"
754 
755 (defun expand-pathname-fix-ups (path)
756        (let ((where-up (index path "<")))
757             (cond ((zerop where-up) path)
758                   (t (expand-pathname-fix-ups
759                        (catenate
760                          (substr path
761                                  1
762                                  (- where-up
763                                     (index (implode
764                                              (reverse
765                                                (explodec
766                                                  (substr path 1 (- where-up 2)))))
767                                            ">")
768                                     1))
769                          (substr path (1+ where-up))))))))
770