-
Notifications
You must be signed in to change notification settings - Fork 10
/
Copy pathdbgp.el
959 lines (860 loc) · 40.4 KB
/
dbgp.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
;;; dbgp.el --- DBGp protocol interface
;; Copyright (C) 2005-2010 reedom <[email protected]>
;; Copyright (C) 2016 Matthew Carter
;; Filename: dbgp.el
;; Author: Matthew Carter <[email protected]>
;; Code derived from Original Author: reedom <[email protected]>
;; Maintainer: Matthew Carter <[email protected]>
;; URL: https://github.com/ahungry/geben
;; Version: 1.0.0
;; Keywords: DBGp, debugger, PHP, Xdebug, Perl, Python, Ruby, Tcl, Komodo
;; Compatibility: Emacs 24+
;; Package-Requires: ((emacs "24") (cl-lib "0.5"))
;; This file is not part of GNU Emacs
;;; License:
;; 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 <http://www.gnu.org/licenses/>.
;;; Commentary:
;;; Code:
(eval-when-compile
(when (or (not (boundp 'emacs-version))
(string< emacs-version "24"))
(error (concat "geben.el: This package requires Emacs 24 or later."))))
(eval-and-compile
(require 'cl-lib)
(require 'xml))
(require 'comint)
;;--------------------------------------------------------------
;; customization
;;--------------------------------------------------------------
;; customize group
(defgroup dbgp nil
"DBGp protocol interface."
:group 'debug)
(defgroup dbgp-highlighting-faces nil
"Faces for DBGp process buffer."
:group 'dbgp
:group 'font-lock-highlighting-faces)
(defcustom dbgp-default-port 9000
"DBGp listener's default port number."
:type 'integer
:group 'dbgp)
(defcustom dbgp-local-address "127.0.0.1"
"Local host address. It is used for DBGp proxy.
This value is passed to DBGp proxy at connection negotiation.
When the proxy receive a new debugging session, the proxy tries
to connect to DBGp listener of this address."
:type 'string
:group 'dbgp)
(defface dbgp-response-face
'((((class color))
:foreground "brightblue"))
"Face for displaying DBGp protocol response message."
:group 'dbgp-highlighting-faces)
(defface dbgp-decoded-string-face
'((((class color))
:inherit 'font-lock-string-face))
"Face for displaying decoded string."
:group 'dbgp-highlighting-faces)
;;--------------------------------------------------------------
;; utilities
;;--------------------------------------------------------------
(defsubst dbgp-plist-get (proc prop)
"Return from process PROC the value of property PROP."
(plist-get (process-plist proc) prop))
(defsubst dbgp-plist-put (proc prop val)
"In process PROC change PROP to VAL."
(let ((plist (process-plist proc)))
(if plist
(plist-put plist prop val)
(set-process-plist proc (list prop val)))))
(defsubst dbgp-xml-get-error-node (xml)
"Return the first node of XML whose child-name is 'error."
(car
(xml-get-children xml 'error)))
(defsubst dbgp-xml-get-error-message (xml)
(let ((err (dbgp-xml-get-error-node xml)))
(if (stringp (car err))
(car err)
(car (xml-node-children
(car (xml-get-children err 'message)))))))
(defsubst dbgp-make-listner-name (port)
(format "DBGp listener<%d>" port))
(defsubst dbgp-process-kill (proc)
"Kill DBGp process PROC."
(if (memq (process-status proc) '(listen open))
(delete-process proc))
;; (ignore-errors
;; (with-temp-buffer
;; (set-process-buffer proc (current-buffer)))))
)
(defsubst dbgp-ip-get (proc)
(cl-first (process-contact proc)))
(defsubst dbgp-port-get (proc)
(cl-second (process-contact proc)))
(defsubst dbgp-proxy-p (proc)
(and (dbgp-plist-get proc :proxy)
t))
(defsubst dbgp-proxy-get (proc)
(dbgp-plist-get proc :proxy))
(defsubst dbgp-listener-get (proc)
(dbgp-plist-get proc :listener))
;;--------------------------------------------------------------
;; DBGp
;;--------------------------------------------------------------
(defcustom dbgp-command-prompt "(cmd) "
"DBGp client process buffer's command line prompt to display."
:type 'string
:group 'dbgp)
;;--------------------------------------------------------------
;; DBGp listener process
;;--------------------------------------------------------------
;; -- What is DBGp listener process --
;;
;; DBGp listener process is a network connection, as an entry point
;; for DBGp protocol connection.
;; The process listens at a specific network address to a specific
;; port for a new session connection(from debugger engine) coming.
;; When a new connection has accepted, the DBGp listener creates
;; a new DBGp session process. Then the new process takes over
;; the connection and the DBGp listener process starts listening
;; for another connection.
;;
;; -- DBGp listener custom properties --
;;
;; :session-init default function for a new DBGp session
;; process to initialize a new session.
;; :session-filter default function for a new DBGp session
;; process to filter protocol messages.
;; :session-sentinel default function for a new DBGp session
;; called when the session is disconnected.
(defvar dbgp-listeners nil
"List of DBGp listener processes.
DBGp listener process is a network connection, as an entry point
for DBGp protocol connection.
The process listens at a specific network address to a specific
port for a new session connection(from debugger engine) coming.
When a new connection has accepted, the DBGp listener creates
a new DBGp session process. Then the new process takes over
the connection and the DBGp listener process starts listening
for another connection.
-- DBGp listener process custom properties --
:session-accept function to determine to accept a new
DBGp session.
:session-init function to initialize a new session.
:session-filter function to filter protocol messages.
:session-sentinel function called when the session is
disconnected.
:proxy if the listener is created for a proxy
connection, this value has a plist of
(:addr :port :idekey :multi-session).
Otherwise the value is nil.")
(defvar dbgp-sessions nil
"List of DBGp session processes.
DBGp session process is a network connection, talks with a DBGp
debugger engine.
A DBGp session process is created by a DBGp listener process
after a DBGp session connection from a DBGp debugger engine
is accepted.
The session process is alive until the session is disconnected.
-- DBGp session process custom properties --
:listener The listener process which creates this
session process.")
(defvar dbgp-listener-port-history nil)
(defvar dbgp-listener-address-history nil)
(defvar dbgp-proxy-address-history nil)
(defvar dbgp-proxy-port-history nil)
(defvar dbgp-proxy-idekey-history nil)
(defvar dbgp-proxy-session-port-history nil)
;;--------------------------------------------------------------
;; interactive read functions
;;--------------------------------------------------------------
(defun dbgp-read-string (prompt &optional initial-input history default-value)
"Read a string from the terminal, not allowing blanks.
Prompt with PROMPT. Whitespace terminates the input.
If non-nil, second arg INITIAL-INPUT is a string to insert before reading.
This argument has been superseded by DEFAULT-VALUE and should normally
be nil in new code. It behaves as in `read-from-minibuffer'. See the
documentation string of that function for details.
The third arg HISTORY, if non-nil, specifies a history list
and optionally the initial position in the list.
See `read-from-minibuffer' for details of HISTORY argument.
Fourth arg DEFAULT-VALUE is the default value. If non-nil, it is used
for history commands, and as the value to return if the user enters
the empty string."
(let (str
(temp-history (and history
(cl-copy-list (symbol-value history)))))
(while
(progn
(setq str (read-string prompt initial-input 'temp-history default-value))
(if (zerop (length str))
(setq str (or default-value ""))
(setq str (replace-regexp-in-string "^[ \t\r\n]+" "" str))
(setq str (replace-regexp-in-string "[ \t\r\n]+$" "" str)))
(zerop (length str))))
(and history
(set history (cons str (remove str (symbol-value history)))))
str))
(defun dbgp-read-integer (prompt &optional default history)
"Read a numeric value in the minibuffer, prompting with PROMPT.
DEFAULT specifies a default value to return if the user just types RET.
The third arg HISTORY, if non-nil, specifies a history list
and optionally the initial position in the list.
See `read-from-minibuffer' for details of HISTORY argument."
(let (n
(temp-history (and history
(mapcar 'number-to-string
(symbol-value history)))))
(while
(let ((str (read-string prompt nil 'temp-history (if (numberp default)
(number-to-string default)
""))))
(ignore-errors
(setq n (cond
((numberp str) str)
((zerop (length str)) default)
((stringp str) (read str)))))
(unless (integerp n)
(message "Please enter a number.")
(sit-for 1)
t)))
(and history
(set history (cons n (remq n (symbol-value history)))))
n))
(defun dbgp-read-port (&optional preset)
(interactive)
(let ((default (or
(car dbgp-listener-port-history)
preset
(default-value 'geben-dbgp-default-port))))
(dbgp-read-integer (format "Listen port(default %s): " default) default 'dbgp-listener-port-history)))
(defun dbgp-read-host ()
(interactive)
(let* ((addrs (append '("0.0.0.0") (mapcar (lambda (intf)
(format-network-address (cdr intf) t))
(network-interface-list))))
(addr-default (or
(car dbgp-listener-address-history)
(and (member "127.0.0.1" addrs) "127.0.0.1")
(car addrs))))
(unless addrs
(error "This machine has no network interface to bind."))
(completing-read (format "Listener address to bind: ") addrs nil t nil 'dbgp-listener-address-history)))
;;--------------------------------------------------------------
;; DBGp listener start/stop
;;--------------------------------------------------------------
(defsubst dbgp-listener-find (port)
(cl-find-if (lambda (listener)
(eq port (cl-second (process-contact listener))))
dbgp-listeners))
;;;###autoload
(defun dbgp-start (host port)
"Start a new DBGp listener listening to PORT."
(interactive
(list
(dbgp-read-host)
(dbgp-read-port)))
(let ((result (dbgp-exec host port
:session-accept 'dbgp-default-session-accept-p
:session-init 'dbgp-default-session-init
:session-filter 'dbgp-default-session-filter
:session-sentinel 'dbgp-default-session-sentinel)))
(when (called-interactively-p 'interactive)
(message (cdr result)))
result))
;;;###autoload
(defun dbgp-exec (host port &rest session-params)
"Start a new DBGp listener listening to PORT.
Set the process up with SESSION-PARAMS."
(if (dbgp-listener-alive-p port)
(cons (dbgp-listener-find port)
(format "The DBGp listener for %d has already been started." port))
(let ((listener (make-network-process :name (dbgp-make-listner-name port)
:host host
:server 1
:service port
:family 'ipv4
:nowait (< emacs-major-version 26) ;; emacs 26 asyncness seems to be too much for now, see issue #4
:noquery t
:filter 'dbgp-comint-setup
:sentinel 'dbgp-listener-sentinel
:log 'dbgp-listener-log)))
(unless listener
(error "Failed to create DBGp listener for port %d" port))
(dbgp-plist-put listener :listener listener)
(and session-params
(nconc (process-plist listener) session-params))
(setq dbgp-listeners (cons listener
(remq (dbgp-listener-find port) dbgp-listeners)))
(cons listener
(format "The DBGp listener for %d is started." port)))))
(defun dbgp-stop (port &optional include-proxy)
"Stop the DBGp listener listening to PORT.
INCLUDE-PROXY may not do anything."
(interactive
(let ((ports (remq nil
(mapcar (lambda (listener)
(and (or current-prefix-arg
(not (dbgp-proxy-p listener)))
(number-to-string (cl-second (process-contact listener)))))
dbgp-listeners))))
(list
;; ask user for the target idekey.
(read (completing-read "Listener port: " ports nil t
(and (eq 1 (length ports))
(car ports))))
current-prefix-arg)))
(let ((listener (dbgp-listener-find port)))
(dbgp-listener-kill port)
(and (called-interactively-p 'interactive)
(message (if listener
"The DBGp listener for port %d is terminated."
"DBGp listener for port %d does not exist.")
port))
(and listener t)))
(defun dbgp-listener-kill (port)
(let ((listener (dbgp-listener-find port)))
(when listener
(delete-process listener))))
;;--------------------------------------------------------------
;; DBGp proxy listener register/unregister
;;--------------------------------------------------------------
;;;###autoload
(defun dbgp-proxy-register (proxy-ip-or-addr proxy-port idekey multi-session-p &optional session-port)
"Register a new DBGp listener to an external DBGp proxy.
The proxy should be found at PROXY-IP-OR-ADDR / PROXY-PORT.
This creates a new DBGp listener and register it to the proxy
associating with the IDEKEY.
MULTI-SESSION-P indicates if multiple sessions are running or not.
SESSION-PORT is either the integer port number, or t."
(interactive (list
(let ((default (or (car dbgp-proxy-address-history) "localhost")))
(dbgp-read-string (format "Proxy address (default %s): " default)
nil 'dbgp-proxy-address-history default))
(let ((default (or (car dbgp-proxy-port-history) 9001)))
(dbgp-read-integer (format "Proxy port (default %d): " default)
default 'dbgp-proxy-port-history))
(dbgp-read-string "IDE key: " nil 'dbgp-proxy-idekey-history)
(not (memq (read-char "Multi session(Y/n): ") '(?N ?n)))
(let ((default (or (car dbgp-proxy-session-port-history) t)))
(unless (numberp default)
(setq default 0))
(dbgp-read-integer (format "Port for debug session (%s): "
(if (< 0 default)
(format "default %d, 0 to use any free port" default)
(format "leave empty to use any free port")))
default 'dbgp-proxy-session-port-history))))
(let ((result (dbgp-proxy-register-exec proxy-ip-or-addr proxy-port idekey multi-session-p
(if (integerp session-port) session-port t)
:session-accept 'dbgp-default-session-accept-p
:session-init 'dbgp-default-session-init
:session-filter 'dbgp-default-session-filter
:session-sentinel 'dbgp-default-session-sentinel)))
(and (called-interactively-p 'interacive)
(consp result)
(message (cdr result)))
result))
;;;###autoload
(defun dbgp-proxy-register-exec (ip-or-addr port idekey multi-session-p session-port &rest session-params)
"Register a new DBGp listener to an external DBGp proxy.
The proxy should be found at IP-OR-ADDR / PORT.
This create a new DBGp listener and register it to the proxy
associating with the IDEKEY.
MULTI-SESSION-P indicates if multiple sessions are running or not.
SESSION-PORT is either the integer port number, or t.
SESSION-PARAMS are added to the listener process."
(cl-block dbgp-proxy-register-exec
;; check whether the proxy listener already exists
(let ((listener (cl-find-if (lambda (listener)
(let ((proxy (dbgp-proxy-get listener)))
(and proxy
(equal ip-or-addr (plist-get proxy :addr))
(eq port (plist-get proxy :port))
(equal idekey (plist-get proxy :idekey)))))
dbgp-listeners)))
(if listener
(cl-return-from dbgp-proxy-register-exec
(cons listener
(format "The DBGp proxy listener has already been started. idekey: %s" idekey)))))
;; send commands to the external proxy instance
(let* ((listener-proc (make-network-process :name "DBGp proxy listener"
:server t
:service (if (and (numberp session-port) (< 0 session-port))
session-port
t)
:family 'ipv4
:noquery t
:filter 'dbgp-comint-setup
:sentinel 'dbgp-listener-sentinel))
(listener-port (cl-second (process-contact listener-proc)))
(result (dbgp-proxy-send-command ip-or-addr port
(format "proxyinit -a %s:%s -k %s -m %d"
dbgp-local-address listener-port idekey
(if multi-session-p 1 0)))))
(if (and (consp result)
(not (equal "1" (xml-get-attribute result 'success))))
;; successfully connected to the proxy, but respond an error.
;; try to send another command.
(setq result (dbgp-proxy-send-command ip-or-addr port
(format "proxyinit -p %s -k %s -m %d"
listener-port idekey
(if multi-session-p 1 0)))))
(when (not (and (consp result)
(equal "1" (xml-get-attribute result 'success))))
;; connection failed or the proxy respond an error.
;; give up.
(dbgp-process-kill listener-proc)
(cl-return-from dbgp-proxy-register-exec
(if (not (consp result))
(cons result
(cond
((eq :proxy-not-found result)
(format "Cannot connect to DBGp proxy \"%s:%s\"." ip-or-addr port))
((eq :no-response result)
"DBGp proxy responds no message.")
((eq :invalid-xml result)
"DBGp proxy responds with invalid XML.")
(t (symbol-name result))))
(cons :error-response
(format "DBGp proxy returns an error: %s"
(dbgp-xml-get-error-message result))))))
;; well done.
(dbgp-plist-put listener-proc :proxy (list :addr ip-or-addr
:port port
:idekey idekey
:multi-session multi-session-p))
(dbgp-plist-put listener-proc :listener listener-proc)
(and session-params
(nconc (process-plist listener-proc) session-params))
(setq dbgp-listeners (cons listener-proc dbgp-listeners))
(cons listener-proc
(format "New DBGp proxy listener is registered. idekey: `%s'" idekey)))))
;;;###autoload
(defun dbgp-proxy-unregister (idekey &optional proxy-ip-or-addr proxy-port)
"Unregister the DBGp listener associated with IDEKEY from a DBGp proxy.
After unregistration, it kills the listener instance.
PROXY-IP-OR-ADDR is the ip or host address of the proxy instance.
PROXY-PORT is the port number."
(interactive
(let (proxies idekeys idekey)
;; collect idekeys.
(mapc (lambda (listener)
(let ((proxy (dbgp-proxy-get listener)))
(and proxy
(setq proxies (cons listener proxies))
(add-to-list 'idekeys (plist-get proxy :idekey)))))
dbgp-listeners)
(or proxies
(error "No DBGp proxy listener exists."))
;; ask user for the target idekey.
(setq idekey (completing-read "IDE key: " idekeys nil t
(and (eq 1 (length idekeys))
(car idekeys))))
;; filter proxies and leave ones having the selected ideky.
(setq proxies (cl-remove-if (lambda (proxy)
(not (equal idekey (plist-get (dbgp-proxy-get proxy) :idekey))))
proxies))
(let ((proxy (if (= 1 (length proxies))
;; solo proxy.
(car proxies)
;; two or more proxies has the same ideky.
;; ask user to select a proxy unregister from.
(let* ((addrs (mapcar (lambda (proxy)
(let ((prop (dbgp-proxy-get proxy)))
(format "%s:%s" (plist-get prop :addr) (plist-get prop :port))))
proxies))
(addr (completing-read "Proxy candidates: " addrs nil t (car addrs)))
(pos (cl-position addr addrs)))
(and pos
(nth pos proxies))))))
(list idekey
(plist-get (dbgp-proxy-get proxy) :addr)
(plist-get (dbgp-proxy-get proxy) :port)))))
(let* ((proxies
(remq nil
(mapcar (lambda (listener)
(let ((prop (dbgp-proxy-get listener)))
(and prop
(equal idekey (plist-get prop :idekey))
(or (not proxy-ip-or-addr)
(equal proxy-ip-or-addr (plist-get prop :addr)))
(or (not proxy-port)
(equal proxy-port (plist-get prop :port)))
listener)))
dbgp-listeners)))
(proxy (if (< 1 (length proxies))
(error "Multiple proxies are found. Needs more parameters to determine for unregistration.")
(car proxies)))
(result (and proxy
(dbgp-proxy-unregister-exec proxy)))
(status (cons result
(cond
((processp result)
(format "The DBGp proxy listener of `%s' is unregistered." idekey))
((null result)
(format "DBGp proxy listener of `%s' is not registered." idekey))
((stringp result)
(format "DBGp proxy returns an error: %s" result))
((eq :proxy-not-found result)
(format "Cannot connect to DBGp proxy \"%s:%s\"." proxy-ip-or-addr proxy-port))
((eq :no-response result)
"DBGp proxy responds no message.")
((eq :invalid-xml result)
"DBGp proxy responds with invalid XML.")))))
(and (called-interactively-p 'interactive)
(cdr status)
(message (cdr status)))
status))
;;;###autoload
(defun dbgp-proxy-unregister-exec (proxy)
"Unregister PROXY from a DBGp proxy.
After unregistration, it kills the listener instance."
(with-temp-buffer
(let* ((prop (dbgp-proxy-get proxy))
(result (dbgp-proxy-send-command (plist-get prop :addr)
(plist-get prop :port)
(format "proxystop -k %s" (plist-get prop :idekey)))))
;; no matter of the result, remove proxy listener from the dbgp-listeners list.
(dbgp-process-kill proxy)
(if (consp result)
(or (equal "1" (xml-get-attribute result 'success))
(dbgp-xml-get-error-message result))
result))))
(defun dbgp-sessions-kill-all ()
(interactive)
(mapc 'delete-process dbgp-sessions)
(setq dbgp-sessions nil))
;;--------------------------------------------------------------
;; DBGp listener functions
;;--------------------------------------------------------------
(defun dbgp-proxy-send-command (addr port string)
"Send DBGp proxy command string to an external DBGp proxy.
ADDR and PORT is the address of the target proxy.
This function returns an xml list if the command succeeds,
or a symbol: `:proxy-not-found', `:no-response', or `:invalid-xml'.
STRING is a string, the command sent into the process."
(with-temp-buffer
(let ((proc (ignore-errors
(make-network-process :name "DBGp proxy negotiator"
:buffer (current-buffer)
:host addr
:service port
:sentinel (lambda (proc string) ""))))
xml)
(if (null proc)
:proxy-not-found
(process-send-string proc string)
(dotimes (x 50)
(if (= (point-min) (point-max))
(sit-for 0.1 t)))
(if (= (point-min) (point-max))
:no-response
(or (ignore-errors
(setq xml (car (xml-parse-region (point-min) (point-max)))))
:invalid-xml))))))
(defun dbgp-listener-alive-p (port)
"Return t if any listener for PORT is alive."
(let ((listener (dbgp-listener-find port)))
(and listener
(eq 'listen (process-status listener)))))
;;--------------------------------------------------------------
;; DBGp listener process log and sentinel
;;--------------------------------------------------------------
(defun dbgp-listener-sentinel (proc string)
(with-current-buffer (get-buffer-create "*DBGp Listener*")
(insert (format "[SNT] %S %s\n" proc string)))
(setq dbgp-listeners (remq proc dbgp-listeners)))
(defun dbgp-listener-log (&rest arg)
(with-current-buffer (get-buffer-create "*DBGp Listener*")
(insert (format "[LOG] %S\n" arg))))
;;--------------------------------------------------------------
;; DBGp session process filter and sentinel
;;--------------------------------------------------------------
(defvar dbgp-filter-defer-flag nil
"Non-nil means don't process anything from the debugger right now.
It is saved for when this flag is not set.")
(defvar dbgp-filter-defer-faced nil
"Non-nil means this is text that has been saved for later in `gud-filter'.")
(defvar dbgp-filter-pending-text nil
"Non-nil means this is text that has been saved for later in `gud-filter'.")
(defvar dbgp-delete-prompt-marker nil)
(defvar dbgp-filter-input-list nil)
(defvar dbgp-buffer-process nil
"The DBGp buffer process.")
(put 'dbgp-buffer-process 'permanent-local t)
;; (defadvice open-network-stream (around debugclient-pass-process-to-comint last)
;; "[comint hack] Pass the spawned DBGp client process to comint."
;; (let* ((buffer (ad-get-arg 1))
;; (proc (buffer-local-value 'dbgp-buffer-process buffer)))
;; (if proc (progn (set-process-buffer proc buffer)
;; (setq ad-return-value proc)))))
(defun dbgp-comint-setup (proc string)
"Setup a new comint buffer for a newly created session process PROC.
This is the first filter function for a new session process created by a
listener process. After the setup is done, `dbgp-session-filter' function
takes over the filter.
STRING would be the command, but doesn't appear to be used."
(if (not (dbgp-session-accept-p proc))
;; multi session is disabled
(when (memq (process-status proc) '(run connect open))
;; refuse this session
(set-process-filter proc nil)
(set-process-sentinel proc nil)
(process-send-string proc "run -i 1\0")
(dotimes (i 50)
(and (eq 'open (process-status proc))
(sleep-for 0 1)))
(dbgp-process-kill proc))
;; accept
(setq dbgp-sessions (cons proc dbgp-sessions))
;; initialize sub process
(set-process-query-on-exit-flag proc nil)
(let* ((listener (dbgp-listener-get proc))
(buffer-name (format "DBGp <%s:%s>"
(cl-first (process-contact proc))
(cl-second (process-contact listener))))
(buf (or (cl-find-if (lambda (buf)
;; find reusable buffer
(let ((proc (get-buffer-process buf)))
(and (buffer-local-value 'dbgp-buffer-process buf)
(not (and proc
(eq 'open (process-status proc)))))))
(buffer-list))
(get-buffer-create buffer-name))))
(with-current-buffer buf
(rename-buffer buffer-name)
;; store PROC to `dbgp-buffer-process'.
;; later the adviced `open-network-stream' will pass it
;; comint.
(set (make-local-variable 'dbgp-buffer-process) proc)
(set (make-local-variable 'dbgp-filter-defer-flag) nil)
(set (make-local-variable 'dbgp-filter-defer-faced) nil)
(set (make-local-variable 'dbgp-filter-input-list) nil)
(set (make-local-variable 'dbgp-filter-pending-text) nil))
;; setup comint buffer
(ad-enable-advice 'open-network-stream 'around 'debugclient-pass-process-to-comint)
(ad-activate 'open-network-stream)
(unwind-protect
(make-comint-in-buffer "DBGp-Client" buf (cons t t))
(ad-deactivate 'open-network-stream)
(ad-disable-advice 'open-network-stream 'around 'debugclient-pass-process-to-comint))
;; update PROC properties
(set-process-filter proc #'dbgp-session-filter)
(set-process-sentinel proc #'dbgp-session-sentinel)
(with-current-buffer buf
(set (make-local-variable 'dbgp-delete-prompt-marker)
(make-marker))
;;(set (make-local-variable 'comint-use-prompt-regexp) t)
;;(setq comint-prompt-regexp (concat "^" dbgp-command-prompt))
(setq comint-input-sender 'dbgp-session-send-string)
;; call initializer function
(funcall (or (dbgp-plist-get listener :session-init)
'null)
proc))
(dbgp-session-filter proc string))))
(defun dbgp-session-accept-p (proc)
"Determine whether PROC should be accepted to be a new session."
(let ((accept-p (dbgp-plist-get proc :session-accept)))
(or (not accept-p)
(funcall accept-p proc))))
(defun dbgp-session-send-string (proc string &optional echo-p)
"Send to process PROC a DBGp protocol STRING.
If ECHO-P is t, echo the input as well."
(if echo-p
(dbgp-session-echo-input proc string))
(comint-send-string proc (concat string "\0")))
(defun dbgp-session-echo-input (proc string)
(with-current-buffer (process-buffer proc)
(if dbgp-filter-defer-flag
(setq dbgp-filter-input-list
(append dbgp-filter-input-list (list string)))
(let ((eobp (eobp))
(process-window (get-buffer-window (current-buffer))))
(save-excursion
(save-restriction
(widen)
(goto-char (process-mark proc))
(insert (propertize
(concat string "\n")
'front-sticky t
'font-lock-face 'comint-highlight-input))
(set-marker (process-mark proc) (point))))
(when eobp
(if process-window
(with-selected-window process-window
(goto-char (point-max)))
(goto-char (point-max))))))))
(defun dbgp-session-filter (proc string)
"Given process PROC and string STRING, this is where the actual buffer insertion is done."
(let ((buf (process-buffer proc))
(listener (dbgp-listener-get proc))
(session-filter (dbgp-plist-get proc :session-filter))
output process-window chunks)
(cl-block dbgp-session-filter
(unless (buffer-live-p buf)
(cl-return-from dbgp-session-filter))
(with-current-buffer buf
(when dbgp-filter-defer-flag
;; If we can't process any text now,
;; save it for later.
(setq dbgp-filter-defer-faced t
dbgp-filter-pending-text (if dbgp-filter-pending-text
(concat dbgp-filter-pending-text string)
string))
(cl-return-from dbgp-session-filter))
;; If we have to ask a question during the processing,
;; defer any additional text that comes from the debugger
;; during that time.
(setq dbgp-filter-defer-flag t)
(setq dbgp-filter-defer-faced nil)
(ignore-errors
;; Process now any text we previously saved up.
(setq dbgp-filter-pending-text (if dbgp-filter-pending-text
(concat dbgp-filter-pending-text string)
string))
(setq chunks (dbgp-session-response-to-chunk))
;; If we have been so requested, delete the debugger prompt.
(if (marker-buffer dbgp-delete-prompt-marker)
(save-restriction
(widen)
(let ((inhibit-read-only t))
(delete-region (process-mark proc)
dbgp-delete-prompt-marker)
(comint-update-fence)
(set-marker dbgp-delete-prompt-marker nil))))
;; Save the process output, checking for source file markers.
(and chunks
(setq output
(concat
(mapconcat (if (functionp session-filter)
(lambda (chunk) (funcall session-filter proc chunk))
#'quote)
chunks
"\n")
"\n"))
(setq output
(concat output
(if dbgp-filter-input-list
(mapconcat (lambda (input)
(concat
(propertize dbgp-command-prompt
'font-lock-face 'comint-highlight-prompt)
(propertize (concat input "\n")
'font-lock-face 'comint-highlight-input)))
dbgp-filter-input-list
"")
dbgp-command-prompt)))
(setq dbgp-filter-input-list nil))))
;; Let the comint filter do the actual insertion.
;; That lets us inherit various comint features.
(and output
(ignore-errors
(comint-output-filter proc output))))
(when (and (buffer-live-p buf)
(with-current-buffer buf
(setq dbgp-filter-defer-flag nil)
dbgp-filter-defer-faced))
(dbgp-session-filter proc ""))))
(defun dbgp-session-response-to-chunk ()
(let* ((string dbgp-filter-pending-text)
(send (length string)) ; string end
(lbeg 0) ; line begin
tbeg ; text begin
tlen ; text length
(i 0) ; running pointer
chunks)
(while (< i send)
(if (< 0 (elt string i))
(cl-incf i)
(setq tlen (string-to-number (substring string lbeg i)))
(setq tbeg (1+ i))
(setq i (+ tbeg tlen))
(when (< i send)
(setq chunks (cons (substring string tbeg i) chunks))
(cl-incf i)
(setq lbeg i))))
;; Remove chunk from `dbgp-filter-pending-text'.
(setq dbgp-filter-pending-text
(and (< lbeg i)
(substring dbgp-filter-pending-text lbeg)))
(nreverse chunks)))
(defun dbgp-session-sentinel (proc string)
(let ((sentinel (dbgp-plist-get proc :session-sentinel)))
(ignore-errors
(and (functionp sentinel)
(funcall sentinel proc string))))
(setq dbgp-sessions (remq proc dbgp-sessions)))
;;--------------------------------------------------------------
;; default session initializer, filter and sentinel
;;--------------------------------------------------------------
(defun dbgp-default-session-accept-p (proc)
"Determine whether PROC should be accepted to be a new session."
(or (not dbgp-sessions)
(if (dbgp-proxy-p proc)
(plist-get (dbgp-proxy-get proc) :multi-session)
(dbgp-plist-get proc :multi-session))))
(defun dbgp-default-session-init (proc)
(with-current-buffer (process-buffer proc)
(pop-to-buffer (current-buffer))))
(defun dbgp-default-session-filter (proc string)
(with-temp-buffer
;; parse xml
(insert (replace-regexp-in-string "\n" "" string))
(let ((xml (car (xml-parse-region (point-min) (point-max))))
text)
;; if the xml has a child node encoded with base64, decode it.
(when (equal "base64" (xml-get-attribute xml 'encoding))
;; remain decoded string
(setq text (with-current-buffer (process-buffer proc)
(decode-coding-string
(base64-decode-string (car (xml-node-children xml)))
buffer-file-coding-system)))
;; decoded string may have invalid characters for xml,
;; so replace the child node with a placeholder
(setcar (xml-node-children xml) "\0"))
;; create formatted xml string
(erase-buffer)
(when (string-match "^.*?\\?>" string)
(insert (match-string 0 string))
(insert "\n"))
(xml-print (list xml))
(add-text-properties (point-min)
(point-max)
(list 'front-sticky t
'font-lock-face 'dbgp-response-face))
(when text
;; restore decoded string into a right place
(goto-char (point-min))
(and (search-forward "\0" nil t)
(replace-match (propertize (concat "\n" text)
'front-sticky t
'font-lock-face 'dbgp-decoded-string-face)
nil t)))
;; return a formatted xml string
(buffer-string))))
(defun dbgp-default-session-sentinel (proc string)
(let ((output "\nDisconnected.\n\n"))
(when (buffer-live-p (process-buffer proc))
(dbgp-session-echo-input proc output))))
(defadvice open-network-stream (around debugclient-pass-process-to-comint )
"[comint hack] Pass the spawned DBGp client process to comint."
(let* ((buffer (ad-get-arg 1))
(proc (buffer-local-value 'dbgp-buffer-process buffer)))
(set-process-buffer proc buffer)
(setq ad-return-value proc) ))
;;(ad-unadvise 'open-network-stream)
;;(ad-deactivate 'open-network-stream )
(ad-disable-advice 'open-network-stream 'around 'debugclient-pass-process-to-comint)
(provide 'dbgp)
;;; dbgp.el ends here