1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
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
97
98 (setq qsend-ok-flag nil
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
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
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
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
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
230
231
232 (declare (defpl1 olcn$olcn2 "" (char (*)) (char (*)))
233 (special olc-messages))
234
235
236 (defvar olc-messages nil)
237 (defvar keep-unresponded-buffers-modified nil)
238
239 (defun console-message-interrupt-handler (intno mbx arg)
240 intno
241
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)
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
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
347
348
349
350
351
352 (defun massage-message-sender (sender)
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)
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)
363
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
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)
413
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
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
507
508
509
510
511
512
513 (defun respond-from-buffer ()
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))
553
554 (defun message-response-command ()
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 ()
579 ((lambda (str)
580 (substr str 1 (1- (stringlength str))))
581 (curline-as-string)))
582
583
584
585
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)))
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))))))
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
649
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
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
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))
739 ((samepnamep relative "process_dir")
740 process-dir)
741 (t (expand-pathname-relative relative
742 "working_dir"))))))
743 (cond ((samepnamep (substr path 1 1) ">") path)
744 ((= lexpr 0) rel)
745 ((null path) rel)
746 ((nullstringp path) rel)
747 (t (expand-pathname-fix-ups
748 (catenate rel
749 ">"
750 path)))))))
751
752
753
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