-
Notifications
You must be signed in to change notification settings - Fork 9
/
Copy pathmagik-cb.el
executable file
·2475 lines (2198 loc) · 100 KB
/
magik-cb.el
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
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
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
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
;;; magik-cb.el --- Class Browser for Magik methods and classes.
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
;;; Commentary:
;;
;;; Works in conjunction with the method_finder C program.
;;
;; The Smallworld Class Browser - CB
;; -----------------------------------
;;
;; There is a main cb buffer that has to be called "*cb*" and a collection of
;; global rather than buffer-local variables. Note that this doesn't
;; completely rule out the use of more than one cb at a time because the main
;; cb buffer could be renamed and its state taken with it in some form.
;; Also cb processes are fairly heavy and if someone really wants another
;; cb they can start another Emacs.
;;
;; The subsidiary cb buffer, for want of a better name, is called "*cb2*"
;; and is meant to be temporary. (All the useful cb state is kept in the
;; cb globals, which makes debugging a lot easier because the globals are
;; readable and settable from the Lisp buffers). At different times the
;; "*cb2*" buffer behaves in quite different ways (topic selection,
;; family-tree display, full method details display), but its mode is
;; always cb-mode (just like the main "*cb*" buffer).
;;
;; Entry to the cb is usually via F3 F3 which basically does "C-x 4 b
;; *cb*". We also record some details of the window configuration so
;; that exit is smoother. A typical window layout at Smallworld is a
;; Magik window at the top and the gis at the bottom. When they first
;; press F3 F3, the cb replaces the gis in the bottom window, and more or
;; less stays there while any temporary subsidiary action takes place in
;; the top window. This is so that the user can see the documentation in
;; relation to the source code they were pondering at the time. Exit is
;; via the space key or F3 q and will destroy any subsidiary buffers on
;; the first press and bury the main cb buffer on the second press. i.e.
;; the user backs out of the cb in the two stages that he came in by.
;;
;; The cb process is called "cb" and the process itself is kept in the
;; local variable, magik-cb-process.
;;
;; The only useful state that is kept in the "*cb*" buffer is the last
;; dollop of output from the C, and the position the user has moved point
;; to (so that the alphabetical position can be preserved). It does no
;; harm if the contents get lost, because all the state is kept in the cb
;; globals. However, the buffer has to be kept because the cb process
;; belongs to it.
;;
;; We talk to the cb process with "(magik-cb-send-string str ...)".
;;
;; The distinction between topics and flags is now blurred. They are
;; both represented in one global association list, cb-topics.
;;
;;
;; 12/7/94 main changes:
;;
;; simplified startup because the method finder automatically
;; does print_curr_methods after loading a file.
;;
;; much less initialisation parameters being sent because there
;; is a reset in the method_finder that matches what we want, and
;; because the method_finder sets the clients queries to how we
;; want as well.
;;
;; startup is further simplified by only allowing F3 F3 as the
;; the startup command.
;;; Code:
(eval-when-compile
(defvar msb-menu-cond))
(require 'magik-mode)
(require 'magik-session)
(require 'magik-utils)
(require 'easymenu)
(require 'compat)
(defgroup magik-cb nil
"Running Magik Class Browser."
:tag "Class Browser"
:group 'magik
:group 'tools)
(defconst magik-cb-in-keyword " IN "
"The method 'IN' class keyword.")
(defgroup magik-cb-faces nil
"Fontification colours for Class Browser."
:group 'magik-cb)
(defface magik-cb-font-lock-optional-face
'((((type tty) (class color)) (:foreground "yellow" :weight light))
(((class grayscale) (background light))
(:foreground "Gray90" :bold t))
(((class grayscale) (background dark))
(:foreground "DimGray" :bold t))
(((class color) (background light)) (:bold t :foreground "DarkGoldenrod"))
(((class color) (background dark)) (:bold t :foreground "LightGoldenrod"))
(t (:bold t)))
"Font-lock Face to use when displaying _optional variables.
Based upon `font-lock-variable-name-face'"
:group 'magik-cb-faces)
(defface magik-cb-cursor-face
'((t (:inverse-video t)))
"Face to use for the Mode line cursor."
:group 'magik-cb-faces)
;; Originally just italic, but due to GDI object leak, made bold too - see magik.el for more details.
(defface magik-cb-font-lock-gather-face
'((((type tty) (class color)) (:foreground "yellow" :weight light))
(((class grayscale) (background light))
(:foreground "Gray90" :italic t))
(((class grayscale) (background dark))
(:foreground "DimGray" :italic t))
(((class color) (background light)) (:italic t :foreground "DarkGoldenrod" :bold t))
(((class color) (background dark)) (:italic t :foreground "LightGoldenrod" :bold t))
(t (:italic t)))
"Font-lock Face to use when displaying _gather variables.
Based upon `font-lock-variable-name-face'"
:group 'magik-cb-faces)
(defcustom magik-cb-font-lock-class-face 'font-lock-type-face
"*Font-lock Face to use when displaying the class."
:group 'magik-cb
:type 'face)
(defcustom magik-cb-font-lock-method-face 'font-lock-function-name-face
"*Font-lock Face to use when displaying the method name."
:group 'magik-cb
:type 'face)
(defcustom magik-cb-font-lock-optional-face 'magik-cb-font-lock-optional-face
"*Font-lock Face to use when displaying the _optional variables."
:group 'magik-cb
:type 'face)
(defcustom magik-cb-font-lock-gather-face 'magik-cb-font-lock-gather-face
"*Font-lock Face to use when displaying the _gather variable."
:group 'magik-cb
:type 'face)
(defcustom magik-cb-cursor-face 'magik-cb-cursor-face
"*Face to use for the Mode line cursor."
:group 'magik-cb
:type 'face)
(defcustom magik-cb-font-lock-keywords
`(("\\*\\*\\*.*" . font-lock-comment-face)
("##.*$" . font-lock-doc-face)
(,(concat "\\(.*\\)" magik-cb-in-keyword "\\(\\S-+\\)")
(1 magik-cb-font-lock-method-face)
(2 magik-cb-font-lock-class-face))
("^\\(\\S-+\\)$" . magik-cb-font-lock-method-face)
("^\\s-+\\(.*\\)\\(OPT.+\\)\\(GATH.+\\)"
(1 font-lock-variable-name-face)
(2 magik-cb-font-lock-optional-face)
(3 magik-cb-font-lock-gather-face))
("^\\s-+\\(.*\\)\\(GATH.+\\)"
(1 font-lock-variable-name-face)
(2 magik-cb-font-lock-gather-face))
("^\\s-+\\(.*\\)\\(OPT.+\\)"
(1 font-lock-variable-name-face)
(2 magik-cb-font-lock-optional-face))
("^\\s-+.*$" . font-lock-variable-name-face)
)
"*Font lock setting for Class Browser fontification."
:group 'magik-cb
:type 'sexp)
;; User configuration options
(defcustom magik-cb-jump-replaces-cb-buffer nil
"*If t, then when jumping to a source file, via \\[cb-jump-to-source],
the file buffer replaces the *cb* buffer.
If nil, the file is displayed in another window and also keeps the *cb* buffer
visible.
The situation where it is useful to set this to t is as follows:
you have two buffers, one with a magik file, the other with
the class browser. If you jump to a file containing a method,
the file containing the method will replace the window displaying the class
browser. Thus, you now have two windows one displaying your magik file
the other displaying the source file containing the method.
You can now use Ediff to compare the buffers!"
:group 'magik-cb
:type 'boolean)
(defcustom magik-cb-generalise-file-name-alist nil
"*An Alist used to modify paths returned by method finder.
Each element is a cons cell (REGEXP . PATH), where REGEXP is matched against
the file name and PATH is the string that replaces a match of REGEXP."
:group 'magik-cb
:type '(alist :key-type regexp :value-type string))
(defcustom magik-cb-coding-system (if (and (boundp 'coding-system-alist)
(assoc "utf-8" coding-system-alist))
'utf-8
'iso-8859-1)
"*Coding system to use for reading the temp file output from the CB process."
:group 'magik-cb
:type 'coding-system)
(defcustom magik-cb-mode-line-cursor " "
"*String to use as the cursor in the mode-line.
`cb-cursor-face' is also used to modify the display of the character
Can be set using \\[cb-set-mode-line-cursor]."
:group 'magik-cb
:type 'string)
(defcustom magik-cb-debug nil
"Set to t to enable debugging output from the C."
:group 'magik-cb
:type 'boolean)
;In case used in a version of Emacs prior to 20
(or (fboundp 'set-process-coding-system)
(defalias 'set-process-coding-system 'ignore))
(defvar magik-cb-buffer-alist nil
"Alist storing CB buffer filename and number used for prefix key switching.")
(defvar magik-cb-process nil
"'method finder' process.")
(put 'magik-cb-process 'permanent-local t)
(defvar magik-cb-topics nil
"Alist of topics and flags.")
(put 'magik-cb-topics 'permanent-local t)
(defvar magik-cb-was-one-window nil
"t if the cb was started from an unsplit-screen configuration.")
(defvar magik-cb-was-started-from-top-half nil
"If the screen was split this tells us whether the cb was invoked
from the top-most window or not.")
(defvar magik-cb-quote-file-name nil
"If t, then method_finder accepts a quoted filename when the file path contains spaces.
Only supported in method_finder version 5.3.0 and above")
(put 'magik-cb-quote-file-name 'permanent-local t)
(defvar magik-cb-mf-extended-flags nil
"If t, then method_finder accepts queries with deprecated and restricted flags.
Only support in method_finder version 6.0.0 and above")
(put 'magik-cb-mf-extended-flags 'permanent-local t)
(defvar magik-cb-temp-method-name nil
"If not nil, name of method used in last pr_source_file command when F3 J is
done from a Magik buffer.")
(defvar magik-cb-filename nil
"Name of file used for the standalone CB session.")
(put 'magik-cb-filename 'permanent-local t)
(defvar magik-cb-filter-str nil
"Contains unprocessed data coming back from the C.
This has to be kept between calls to the filter because the
data can return in different size lumps.")
(put 'magik-cb-filter-str 'permanent-local t)
(defvar magik-cb-n-methods-str nil
"A string (possibly of the form \">200\") as returned by the C.
This is displayed in the modeline.")
(put 'magik-cb-n-methods-str 'permanent-local t)
(defvar magik-cb-topic-pos nil
"Where the user's cursor was when they last left the topics selection mode.
We don't rely on the state of the \"*cb2*\" buffer because it is only temporary.")
(put 'magik-cb-topic-pos 'permanent-local t)
(defvar magik-cb-cursor-pos nil
"Whether the CB modeline cursor is in the method or class part of the modeline.
Takes the values 'method-name and 'class-name.")
(put 'magik-cb-cursor-pos 'permanent-local t)
(defvar magik-cb-pending-message nil
"Whether we should write an empty message when the method_finder gives us an answer.
This will stop the \"Loading documentation...\" message from hanging around.")
(put 'magik-cb-pending-message 'permanent-local t)
(defvar magik-cb-dynamic t
"*Non-nil if the cb is connected to a live gis, rather than a static file.")
(defvar magik-cb--mf-socket-synchronised nil
"Internal variable for controlling Class Browser processes started from GIS processes.
Set to the socketname returned by `gis-filter-action-cb-mf' when starting CB from Gis process via \\[cb].")
;; T O P I C A N D F L A G D A T A
;; _____________________________________
;;
(defvar magik-cb-initial-topics
'(
("basic" t "add basic" "unadd basic")
("advanced" nil "add advanced" "unadd advanced")
("subclassable" nil "add subclass" "unadd subclass")
("redefinable" nil "add redefinable" "unadd redefinable")
("debug" t "add debug" "unadd debug")
("restricted" nil "add restricted" "unadd restricted")
("deprecated" nil "add deprecated" "unadd deprecated")
("local-only" t "local_only")
("inherit-not-\"object\"" t "inherit_not_obj")
("inherit-from-\"object\"" t "inherit_all")
("show-methods" t "show_method_names" "dont_show_method_names")
("show-classes" t "show_classes" "dont_show_classes")
("show-args" nil "show_args" "dont_show_args")
("show-comments" nil "show_comments" "dont_show_comments")
("show-topics" nil "show_topics" "dont_show_topics")
("override-flags" nil "override_flags" "dont_override_flags")
("override-topics" nil "override_topics" "dont_override_topics")
("override-200-limit" nil "method_cut_off 1000000" "method_cut_off 200")
)
"An association list of all the topics and flags together with
their on/off status and their corresponding commands for sending
to the C.")
(defvar magik-cb-flag-groups
'(("basic" "advanced" "subclassable" "redefinable" "debug" "deprecated" "restricted"))
"List of CB flags.")
(defvar magik-cb-thermometer-group
'("local-only" "inherit-not-\"object\"" "inherit-from-\"object\"")
"A set of 3 flags that should only be on if all the previous ones are on.")
;; C B 2
;; _____
(defvar magik-cb2-mode nil
"The sort of data the subsidiary cb buffer is displaying.
We use this variable instead of inventing new major modes
because the keymaps in all these modes will be the same anyway.")
(defvar magik-cb2-direct-p nil
"Whether the user got directly into \"*cb2*\" without going via \"*cb*\".
This affects the way we might want to exit.
Not used yet.")
(defvar magik-cb2-was-one-window nil
"t if the cb2 was started from an unsplit-screen configuration.")
(defvar magik-cb--ac-candidates nil
"Internal return value from CB auto-complete process.")
(defvar magik-cb-ac-process nil
"Class Browser process object to use for auto-complete-mode.")
(defcustom magik-cb2-font-lock-on-face 'font-lock-function-name-face
"*Font-lock Face to use when displaying the variable."
:group 'magik-cb
:type 'face)
(defcustom magik-cb2-font-lock-off-face 'font-lock-variable-name-face
"*Font-lock Face to use when displaying the variable."
:group 'magik-cb
:type 'face)
(defcustom magik-cb2-font-lock-thermometer-on-face 'font-lock-type-face
"*Font-lock Face to use when displaying a thermometer variable that is on."
:group 'magik-cb
:type 'face)
(defcustom magik-cb2-font-lock-thermometer-off-face 'font-lock-constant-face
"*Font-lock Face to use when displaying a thermometer variable that is off."
:group 'magik-cb
:type 'face)
(defcustom magik-cb2-font-lock-keywords
'(
("[+] \\(\\sw+\\)" 1 magik-cb2-font-lock-on-face)
("[-] \\(\\sw+\\)" 1 magik-cb2-font-lock-off-face)
("[*] \\(\\sw+\\)" 1 magik-cb2-font-lock-thermometer-on-face)
("[.] \\(\\sw+\\)" 1 magik-cb2-font-lock-thermometer-off-face)
("^ .*$" . font-lock-doc-face)
)
"*Font lock setting for Class Browser fontification."
:group 'magik-cb
:type 'sexp)
;;; Functions
;;; _________
(defun magik-cb-gis ()
"Start/goto GIS with the same environment as the current CB process."
(interactive)
(let ((buf (magik-cb-gis-buffer)))
(if (one-window-p t)
(split-window-vertically)
(other-window 1))
(magik-session buf)))
(defun magik-cb-gis-shell ()
"Start a command shell with the same environment as the current CB process."
(interactive)
(let ((gis (magik-cb-gis-buffer)))
(with-current-buffer gis
(magik-session-shell))))
(defun magik-cb-customize ()
"Open Customization buffer for Class Browser Mode."
(interactive)
(customize-group 'magik-cb))
;; S T A R T U P
;; _____________
;;;###autoload
(defun magik-cb (&optional gis method class)
"Start or resume a Smallworld Class Browser.
With a prefix arg, ask user for GIS buffer to associate with.
Main top level entry to the cb.
Create the buffer and/or start the process if necessary.
Do a no-op if already in the cb."
(interactive)
(let (magik-cb-file running-p buffer gis-proc visible-bufs bufs)
(cond ((and (integerp current-prefix-arg) (> current-prefix-arg 0))
(setq gis (magik-utils-get-buffer-mode gis
'magik-session-mode
"Enter Magik process buffer: "
(cond ((eq major-mode 'magik-cb-mode) (magik-cb-gis-buffer))
((eq major-mode 'magik-session-mode) (buffer-name))
(t magik-session-buffer))
'magik-session-buffer-alist-prefix-function))
(unless (get-buffer-process gis)
(pop-to-buffer gis)
(error "There is no process running in this buffer"))
(unless (get-buffer gis)
(pop-to-buffer gis)
(error "No Class Browser is running")))
((and (integerp current-prefix-arg) (< current-prefix-arg 0))
(setq buffer (magik-utils-get-buffer-mode nil
'magik-cb-mode
"Enter Class Browser buffer:"
nil
'magik-cb-buffer-alist-prefix-function
nil
'magik-cb-filename))
(unless (get-buffer buffer)
(pop-to-buffer buffer)
(error "No Class Browser is running")))
(current-prefix-arg
(setq magik-cb-file (magik-cb-set-filename)
buffer (generate-new-buffer-name
(concat "*cb*" "*" (or buffer (file-name-nondirectory magik-cb-file)) "*"))
gis (magik-cb-gis-buffer buffer)))
((eq major-mode 'magik-cb-mode)
(setq gis (magik-cb-gis-buffer)))
((eq major-mode 'magik-session-mode)
(setq gis (buffer-name)))
((and ;List of *visible* cb-mode *and* magik-session-mode buffers.
(setq bufs
(delete nil
(mapcar (function (lambda (b) (if (cdr b) b)))
(setq visible-bufs
(magik-utils-buffer-visible-list '(magik-cb-mode magik-session-mode))))))
;;restrict list to those whose cdr is t.
(setq buffer
(if (= (length bufs) 1)
(caar bufs)
(completing-read
"Enter Class Browser or Magik process buffer: "
visible-bufs 'cdr t)))
(not (equal buffer "")))
(if (equal (substring buffer 0 4) "*cb*")
nil ;;Selected a CB buffer
(setq gis buffer
buffer (concat "*cb*" buffer))))
((and
visible-bufs
(setq buffer
;;Find visible CB buffer in other frame, allowing for a visible GIS buffer too.
(cond ((= (length visible-bufs) 1)
(caar visible-bufs))
((and (= (length visible-bufs) 2)
(equal (substring (caar visible-bufs) 0 4) "*cb*"))
(caar visible-bufs))
((and (= (length visible-bufs) 2)
(equal (substring (caadr visible-bufs) 0 4) "*cb*"))
(caadr visible-bufs))
(t
(completing-read
"Enter Class Browser or Magik process buffer: "
visible-bufs nil t))))
(not (equal buffer "")))
(select-frame-set-input-focus
(window-frame (get-buffer-window buffer 'visible)))
(if (equal (substring buffer 0 4) "*cb*")
nil ;;Selected a CB buffer
(setq gis buffer
buffer (concat "*cb*" buffer))))
((setq buffer (magik-utils-get-buffer-mode nil
'magik-cb-mode
"Enter Class Browser buffer: "
(let ((magik-cb (concat "*cb*" magik-session-buffer)))
(if (get-buffer magik-cb) magik-cb))))
t)
((and magik-session-buffer (get-buffer magik-session-buffer) (get-buffer-process magik-session-buffer))
(setq gis magik-session-buffer))
(t
(setq magik-cb-file (magik-cb-set-filename)
buffer (generate-new-buffer-name
(concat "*cb*" "*" (file-name-nondirectory magik-cb-file) "*"))
gis (magik-cb-gis-buffer buffer))))
(setq buffer (or buffer (concat "*cb*" gis))
gis-proc (and gis (get-buffer-process gis)))
(cond ((magik-cb-is-running buffer)
(setq running-p t)
(compat-call setq-local magik-cb-process (get-buffer-process buffer)))
((and magik-cb-dynamic gis-proc)
(setq buffer (get-buffer-create buffer)))
(t
(setq gis-proc nil)))
(pop-to-buffer buffer)
(with-current-buffer buffer
(if (not running-p)
(progn
(compat-call setq-local magik-cb-process (magik-cb-get-process-create buffer 'magik-cb-filter gis magik-cb-file))
(magik-cb-interactive-buffer)
(sleep-for 0.1)))
(if (not magik-cb-process)
(error "The Class Browser, '%s', is not running" (current-buffer)))
(if (magik-cb-set-method-and-class method class)
(magik-cb-send-modeline-and-pr)
(magik-cb-redraw-modeline))
(magik-cb-set-windows))
))
(defun magik-cb-new-buffer ()
"Start a new Class Browser session."
(interactive)
(let ((current-prefix-arg t))
(call-interactively 'magik-cb)))
(define-derived-mode magik-cb-mode magik-base-mode "Magik-CB"
"Major mode for running the Smallworld Class Browser.
Full help is available on the CB pull-down menu or by typing
Use \\<magik-cb-mode-map>\\[magik-cb-help] for help.
Useful configuration variables are:
cb-jump-replaces-cb-buffer
To view the help on these variables type \\[describe-variable] and enter the variable name.
\\{magik-cb-mode-map}"
:group 'magik
:abbrev-table nil
(compat-call setq-local
buffer-read-only t
buffer-undo-list t
show-trailing-whitespace nil
font-lock-defaults '(magik-cb-font-lock-keywords nil t ((?_ . "w")))
magik-cb-process (magik-cb-process)
magik-cb-topics (mapcar #'(lambda (x) (append x ())) magik-cb-initial-topics)
magik-cb-quote-file-name nil
magik-cb-mf-extended-flags nil
magik-cb-filename nil
magik-cb-filter-str ""
magik-cb-n-methods-str "0"
magik-cb-topic-pos 1
magik-cb-cursor-pos 'method-name
magik-cb-pending-message t)
(add-hook 'menu-bar-update-hook 'magik-cb-update-tools-magik-cb-menu nil t)
(add-hook 'kill-buffer-hook 'magik-cb-buffer-alist-remove nil t))
(defvar magik-cb-menu nil
"Keymap for the CB menu bar.")
(easy-menu-define magik-cb-menu magik-cb-mode-map
"Menu for CB mode."
`(,"CB"
[,"Jump to Source" magik-cb-jump-to-source :active t :keys "<f3> j, <mouse-2>"]
[,"Family Tree" magik-cb-family :active t :keys "<f3> f, <mouse-2>"]
[,"Fold" magik-cb-fold (or (magik-cb-topic-on-p "show-topics")
(magik-cb-topic-on-p "show-comments")
(magik-cb-topic-on-p "show-args")
(magik-cb-topic-on-p "show-classes"))]
[,"Unfold" magik-cb-unfold (or (not (magik-cb-topic-on-p "show-topics"))
(not (magik-cb-topic-on-p "show-comments"))
(not (magik-cb-topic-on-p "show-args"))
(not (magik-cb-topic-on-p "show-classes")))]
"---"
[,"Set Options" magik-cb-edit-topics-and-flags :active t :keys "<f3> s, ;"]
[,"Turn All Topics On/Off" magik-cb-toggle-all-topics t]
[,"Reset All Options" magik-cb-reset t]
[,"Hide" magik-cb-quit :active t :keys "SPC, <f3> h"]
"---"
[,"Override Flags"
magik-cb-toggle-override-flags
:active t
:style toggle
:selected (magik-cb-topic-on-p "override-flags")
:keys "<f3> F, <f3> o"]
[,"Override Topics"
magik-cb-toggle-override-topics
:active t
:style toggle
:selected (magik-cb-topic-on-p "override-topics")]
[,"Override 200 Limit"
magik-cb-toggle-override-200-limit
:active t
:style toggle
:selected (magik-cb-topic-on-p "override-200-limit")]
"---"
[,"Hop" magik-cb-tab t]
[,"Clear" magik-cb-clear t]
[,"Clear Method and Class" magik-cb-and-clear t]
"---"
[,"Magik Process" magik-cb-gis (get-buffer (magik-cb-gis-buffer))]
[,"Magik External Shell Process" magik-cb-gis-shell (get-buffer
(concat "*shell*" (magik-cb-gis-buffer)))]
"---"
[,"Customize" magik-cb-customize t]
;; [,"Help" magik-cb-help t]
))
(defun magik-cb-gis-buffer (&optional buffer)
"Return the GIS process buffer associated with this Class Browser."
(setq buffer (if (bufferp buffer) (buffer-name buffer) (or buffer (buffer-name))))
(let ((magik-cb-bit (substring buffer 0 5)))
(if (equal magik-cb-bit "*cb2*")
(substring buffer 5)
(substring buffer 4))))
(defun magik-cb-buffer (&optional buffer)
"Name of the CB buffer."
(get-buffer-create (concat "*cb*" (magik-cb-gis-buffer buffer))))
(defun magik-cb-process (&optional buffer)
"Process object of the CB buffer.
If `cb-process' is not nil, returns that irrespective of given BUFFER."
(or magik-cb-process (get-buffer-process (magik-cb-buffer buffer))))
(defun magik-cb-topics (&optional newval buffer)
"Get/Set `cb-topics' variable from the CB buffer."
(with-current-buffer (magik-cb-buffer buffer)
(if newval
(compat-call setq-local magik-cb-topics newval)
magik-cb-topics)))
(defun magik-cb-cursor-pos (&optional newval buffer)
"Get/Set `cb-cursor-pos' variable from the CB buffer."
(with-current-buffer (magik-cb-buffer buffer)
(if newval
(compat-call setq-local magik-cb-cursor-pos newval)
magik-cb-cursor-pos)))
(defun magik-cb-mf-extended-flags (&optional buffer)
"Get `cb-mf-extended-flags' variable from the CB buffer."
(with-current-buffer (magik-cb-buffer buffer)
magik-cb-mf-extended-flags))
(defun magik-cb-buffer-alist-remove ()
"Remove current buffer from `magik-cb-buffer-alist'."
(let ((c (rassoc (buffer-name) magik-cb-buffer-alist)))
(if c
(progn
(setcdr c nil)
(car c)))))
(defun magik-cb-buffer-alist-prefix-function (arg mode predicate)
"Function to process prefix keys when used with \\[cb]."
(let (buf)
(cond ((zerop arg) (set buf nil))
((> arg 0)
;; Look for GIS buffers
(setq buf (cdr (assq arg (symbol-value 'magik-session-buffer-alist))))
(unless (and buf
(with-current-buffer buf
(magik-utils-buffer-mode-list-predicate-p predicate)))
(error "There is no process running in this buffer")))
((< arg 0)
;; Look for CB buffers
(setq buf (cdr (assq arg magik-cb-buffer-alist)))
(unless (and buf
(with-current-buffer buf
(magik-utils-buffer-mode-list-predicate-p predicate)))
(error "No Class Browser is running"))))
buf))
(defun magik-cb-update-tools-magik-cb-menu ()
"Update Class Browser Processes submenu in Tools -> Magik pulldown menu."
(let ((magik-cb-gis-alist (sort (copy-alist (symbol-value 'magik-session-buffer-alist))
#'(lambda (a b) (< (car a) (car b))))); 1, 2 etc.
(magik-cb-alist (sort (copy-alist magik-cb-buffer-alist); -1, -2, etc.
#'(lambda (a b) (> (car a) (car b)))))
cb-list)
;; Order is such that CB of *gis* will be first see magik-session.el for more details.
(dolist (c magik-cb-alist)
(let ((i (- (car c)))
(buf (cdr c)))
(if buf
(setq cb-list
(append cb-list
(list (vector buf
(list 'display-buffer buf)
':active t
':keys (format "M-- M-%d f3 f3" i))))))))
(setq cb-list (append cb-list (list "---")))
(dolist (c magik-cb-gis-alist)
(let ((i (car c))
(buf (and (cdr c) (concat "*cb*" (cdr c)))))
(if (and buf (get-buffer buf))
(setq cb-list
(append cb-list
(list (vector buf
(list 'display-buffer buf)
':active t
':keys (format "M-%d f3 f3" i))))))))
(easy-menu-change (list "Tools" "Magik")
"Class Browser Processes"
(if (eq (length cb-list) 1)
(list "No Processes")
cb-list))))
(defun magik-cb-gis-get-mf-socketname (gis-process)
"Returns from a GIS process its method_finder socketname interface."
;; The gis-filter will set magik-cb--mf-socket-synchronised, which we trap here.
(setq magik-cb--mf-socket-synchronised nil)
(let ((buffer (buffer-name (process-buffer gis-process)))
(i 1)
magik-cb--mf-socket-synchronised)
(process-send-string gis-process
"method_finder.send_socket_to_emacs()\n$\n")
(while (and (null magik-cb--mf-socket-synchronised) (not (zerop i)))
(if (= i 100)
(progn
(message "The GIS process in buffer %s is busy... Please wait for CB to start" buffer)
(sleep-for 0.01)))
(if (or (not (zerop (% i 1000)))
(not (y-or-n-p (format "The CB cannot start yet because the GIS process in %s is busy... Abort CB" buffer))))
(progn
;; either count i has not reached a multiple of 1000
;; or conunt i is a multiple of 1000 but user has chosen to continue
(sleep-for 0.01)
(setq i (1+ i)))
;; User aborted loop.
(setq i 0)))
(if (and (stringp magik-cb--mf-socket-synchronised) (not (equal magik-cb--mf-socket-synchronised "")))
magik-cb--mf-socket-synchronised)))
(defun magik-cb-start-process (buffer command &rest args)
"Start a COMMAND process in BUFFER and return process object.
BUFFER may be nil, in which case only the process is started."
(let* ((exec-path (append (magik-aliases-layered-products-acp-path (magik-aliases-expand-file magik-aliases-layered-products-file)) exec-path))
magik-cb-process)
(compat-call setq-local magik-cb-process (apply 'start-process "cb" buffer command args))
(set-process-filter magik-cb-process 'magik-cb-filter)
(set-process-sentinel magik-cb-process 'magik-cb-sentinel)
(set-process-coding-system magik-cb-process magik-cb-coding-system magik-cb-coding-system)
(magik-cb-send-tmp-file-name (magik-cb-temp-file-name magik-cb-process))
magik-cb-process))
(defun magik-cb-get-process-create (buffer filter &optional gis cb-file)
"Return a method finder process in BUFFER, creating one using GIS buffer or CB_FILE if needed.
Either starts a method_finder process or if a GIS session is running
it starts a mf_connector process to communicate with the method_finder
in the GIS.
If FILTER is given then it is set on the process."
(setq buffer (get-buffer-create buffer)) ; get a real buffer object.
(if (get-buffer-process buffer)
(get-buffer-process buffer) ;returns running process
(let* ((process-environment (cl-copy-list (save-excursion
(and gis (get-buffer gis) (set-buffer gis))
(or (symbol-value 'magik-session-process-environment)
process-environment))))
(exec-path (cl-copy-list (save-excursion
(and gis (get-buffer gis) (set-buffer gis))
(or (symbol-value 'magik-session-exec-path) exec-path))))
(gis-proc (and gis (get-buffer-process gis)))
magik-cb-process)
(cond (gis-proc
;; then ask Magik to start a method_finder. Magik will
;; tell us if it succeeds in starting a new method_finder.
(let ((socketname (magik-cb-gis-get-mf-socketname gis-proc)))
(if socketname
(compat-call setq-local magik-cb-process (magik-cb-start-process buffer "mf_connector" "-e" socketname))
(if buffer
(with-current-buffer buffer
(let ((buffer-read-only nil))
(goto-char (point-max))
(insert "\n\n*** Can't start the Class Browser. ***\n The gis hasn't started a method_finder.\n Perhaps there was no '.mf' file next to your image file.\n")
(ding) (ding) (ding)
(error "cannot start CB using mf_connector")))))))
(cb-file
;; otherwise start our own method_finder.
(compat-call setq-local magik-cb-process (magik-cb-start-process buffer
"method_finder"
"-e"
;; we give a socket-name or pipe-name
;; even though no-one is going to connect
;; to the method_finder. This is because
;; the method_finder no longer has a single-user mode.
(concat "\\\\.\\pipe\\method_finder\\time"
(number-to-string (cl-first (current-time)))
"."
(number-to-string (cl-second (current-time)))
"\\pointmax"
(number-to-string (point-max)))))
(magik-cb-send-load cb-file))
(t
(error "cannot start CB")))
(if magik-cb-process
(progn
(save-excursion
(let ((version (magik-cb-method-finder-version)))
(set-buffer (get-buffer-create buffer))
(unless (eq major-mode 'magik-cb-mode)
(magik-cb-mode))
(compat-call setq-local
magik-cb-quote-file-name (string< "5.2.0" version)
magik-cb-mf-extended-flags (string< "6.0.0" version)
magik-cb-filename cb-file)))
;; Note that magik-cb-start-process uses magik-cb-filter when the process starts.
;; This is so that it can handle the topic information that the method finder
;; process sends back. At the moment magik-cb-ac-filter (the only other filter in use)
;; does not include that code. A future rework may tidy this up.
(if filter
(set-process-filter magik-cb-process filter))))
magik-cb-process)))
(defun magik-cb-interactive-buffer ()
"Initialise an interactive Class Browser in current buffer"
;;Ensure interaction buffers are empty
(magik-cb-set-method-str "")
(magik-cb-set-class-str "")
(let ((buffer-read-only nil))
(erase-buffer)
(insert " Smallworld Class Browser (Version 2.0)\n --------------------------------------\n"))
(goto-char (point-min))
(magik-cb-redraw-modeline)
(message "Loading the documentation ...")
(magik-cb-print-curr-methods)
(message "")
;; Update magik-cb-buffer-alist using negative numbers if loading from a file,
;; positive numbers are used by magik-session-buffer-alist for loading from GIS
(if (and magik-cb-filename
(not (rassoc (buffer-name) magik-cb-buffer-alist)))
(let ((n -1))
(while (cdr (assq n magik-cb-buffer-alist))
(setq n (1- n)))
(if (assq n magik-cb-buffer-alist)
(setcdr (assq n magik-cb-buffer-alist) (buffer-name))
(add-to-list 'magik-cb-buffer-alist (cons n (buffer-name))))
(assq n magik-cb-buffer-alist))))
(defun magik-cb-set-windows (&optional buffer)
(setq buffer (or buffer (current-buffer)))
(if (get-buffer-window buffer)
(select-window (get-buffer-window buffer))
(setq magik-cb-was-one-window (one-window-p t)
magik-cb-was-started-from-top-half (zerop (cl-second (window-edges (selected-window)))))
(display-buffer buffer)))
(defun magik-cb-set-filename ()
"Read a filename off the user and return it."
(let* ((gis (or (getenv "SMALLWORLD_GIS")
(error "There is no value for the environment variable 'SMALLWORLD_GIS'")))
(completion-ignored-extensions
(cons ".msf" (cons ".mi" completion-ignored-extensions)))
(ans
(expand-file-name
(substitute-in-file-name
(read-file-name "Method Finder File: "
(concat (file-name-as-directory gis) "images/")
nil t)))))
(if (file-directory-p ans)
(error "Please give a filename of an mf file"))
(with-current-buffer (get-buffer-create " *mf header")
(erase-buffer)
(insert-file-contents ans nil 0 4)
(if (or (equal (buffer-string) "mfcb")
(equal (buffer-string) "bcfm")
(y-or-n-p (format "`%s' doesn't seem to be a method_finder file. Load anyway? " ans)))
()
(error "%s not loaded" ans)))
ans))
;; T H E C L A S S B R O W S E R F I L T E R
;; _________________________________________________
(defun magik-cb-filter (p s)
"Process data coming back from the C."
(save-match-data
(let* ((b (process-buffer p))
jump-str)
(set-buffer b)
(if magik-cb-pending-message
(progn
(message "")
(compat-call setq-local magik-cb-pending-message nil)))
;; diagnostic to see if stuff is coming back from the C.
(if magik-cb-debug
(let ((debug-buf (get-buffer-create (concat "*cb debug*" (buffer-name b)))))
(with-current-buffer debug-buf
(insert s)
(message "DEBUG output set to buffer %s" (buffer-name)))))
(compat-call setq-local magik-cb-filter-str (concat magik-cb-filter-str s))
(if (string-match "\C-e" magik-cb-filter-str) (magik-cb-read-methods p))
(if (string-match "\C-u" magik-cb-filter-str) (magik-cb-force-query p))
(if (string-match "\C-c" magik-cb-filter-str) (magik-cb-read-classes p))
(with-current-buffer b
(while (string-match "[\C-t\C-f].*\n" magik-cb-filter-str)
(let ((str (substring magik-cb-filter-str (1+ (match-beginning 0)) (1- (match-end 0)))))
(if (eq (aref magik-cb-filter-str (match-beginning 0)) ?\C-t)
(magik-cb-new-topic str)
(setq jump-str str)))
(compat-call setq-local magik-cb-filter-str (substring magik-cb-filter-str (match-end 0))))
(compat-call setq-local magik-cb-filter-str (if (string-match "[\C-t\C-f]" magik-cb-filter-str)
(substring magik-cb-filter-str (match-beginning 0))
""))
(if jump-str
(magik-cb-goto-method jump-str (eq major-mode 'magik-cb-mode)))))))
(defun magik-cb-read-methods (p)
"Deal with a C-e or a C-u char coming back from the C by loading
from \"/tmp\" into the main cb buffer. Be careful to maintain the
position in the listing. Also extract the number-of-methods from
the last line of the file, and put it in the global `magik-cb-n-methods-str'.
"
(let ((buf (process-buffer p))
(buffer-read-only nil)
(coding-system-for-read magik-cb-coding-system)
method-str)
(or (looking-at "^[^ \n]") (re-search-backward "^[^ \n]" nil 1))
(setq method-str (buffer-substring (line-beginning-position) (line-end-position)))
(erase-buffer)
(insert-file-contents (magik-cb-temp-file-name p))
(goto-char (point-max))
(forward-line -1)
(compat-call setq-local magik-cb-n-methods-str (buffer-substring (point) (line-end-position)))
(delete-region (point) (point-max))
(goto-char (magik-cb-find-latest-<= method-str (point-min) (point-max)))
(if (get-buffer-window buf)
(set-window-point (get-buffer-window buf) (point)))
(magik-cb-redraw-modeline))) ; for the method count.
(defun magik-cb-force-query (p)
"Override the current modeline. The class name pattern is cleared
and the method name pattern is set to match the method name in
cb-temp-method-name. Then a suitable query is sent to the method
finder process to return the list of methods.
None of the current topics or flags settings are overridden.
"
(magik-cb-set-class-str "")
(magik-cb-set-method-str (concat "^" magik-cb-temp-method-name "$") )
(magik-cb-send-modeline-and-pr)
(magik-cb-set-windows (process-buffer p)))
(defun magik-cb-read-classes (p)
"Deal with a C-c character coming back from the C by displaying
the classes in \"*cb2*\".
We assume that whatever lisp requested this info has made sure the
buffer is being displayed in some window. We just dump the data
in \"*cb2*\" and note that \"*cb2*\" is now in family mode.
"