lyskom-buttons.el 39.4 KB
Newer Older
1
;;;;; -*-coding: raw-text;-*-
2
;;;;;
3
;;;; $Id$
4
;;;;; Copyright (C) 1991, 1996  Lysator Academic Computer Association.
5
6
7
8
9
;;;;;
;;;;; This file is part of the LysKOM server.
;;;;; 
;;;;; LysKOM is free software; you can redistribute it and/or modify it
;;;;; under the terms of the GNU General Public License as published by 
10
;;;;; the Free Software Foundation; either version 2, or (at your option) 
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
;;;;; any later version.
;;;;; 
;;;;; LysKOM 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 LysKOM; see the file COPYING.  If not, write to
;;;;; Lysator, c/o ISY, Linkoping University, S-581 83 Linkoping, SWEDEN,
;;;;; or the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, 
;;;;; MA 02139, USA.
;;;;;
;;;;; Please mail bug reports to bug-lyskom@lysator.liu.se. 
;;;;;
;;;; ================================================================
;;;; ================================================================
;;;;
;;;; File: lyskom-buttons.el
;;;; Author: David Byers
;;;;
;;;;

34

35
36
37
38
39
40
41
42
43
44
45
46
47
(setq lyskom-clientversion-long 
      (concat lyskom-clientversion-long
	      "$Id$\n"))

(lyskom-external-function glyph-property)
(lyskom-external-function widget-at)
(lyskom-external-function widget-get)
(lyskom-external-function w3-widget-button-click)
(lyskom-external-function w3-popup-menu)
(lyskom-external-function Info-goto-node)
(lyskom-external-function term-char-mode)


David Byers's avatar
X    
David Byers committed
48
49
50
(defun lyskom-menu-selection nil
  "Variable used to work around the handling of menus in XEmacs.")

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
(defun lyskom-add-button-action (type text func)
  "Add a new action to the popup menu for a class of objects.
Arguments are TYPE, the type of object to adjust, TEXT the menu text
for the action and FUNC, the function to call when the action is
selected. By default TYPE may be any one of text, conf, pers or url 
although users can add other types.

FUNC must be a function with three arguments, BUFFER, ARGUMENT and
TEXT.  BUFFER is the LysKOM buffer that the command should use, TEXT
is the text of the selected button and ARGUMENT is the data argument
associated with the object. For button type text it is a text
number. For types conf and pers it is the conference number for the
object. For URLs it is the text of the URL (a string) or NIL. For
other (user-defined) types, it is a string.

For more information on button types and arguments, see the
documentation for the variable lyskom-text-buttons."
  (nconc (nth 3 (assq type lyskom-button-actions))
	 (list (cons text func))))

(defun lyskom-set-default-button-action (type func)
  "Set the default action for buttons of the type TYPE to FUNC. 

FUNC must be a valid button action function. For more information
on such functions see the documentation for lyskom-add-button-action."
  (let ((el (assq type lyskom-button-actions)))
    (setcdr (nthcdr 1 el)
	    (cons func (nthcdr 3 el)))))
      


82
(defun kom-previous-link (num)
83
  "Move the cursor to the previous active area in the LysKOM buffer."
84
85
  (interactive "p")
  (while (> num 0)
86
87
    (let ((where (previous-single-property-change (point) 
                                                  'lyskom-button-text)))
88
89
      (if where
          (progn
90
91
92
93
            (if (not (get-text-property where 'lyskom-button-text))
                (setq where (previous-single-property-change 
                             where
                             'lyskom-button-text)))
94
95
96
97
98
99
100
            (if where
                (goto-char where)
              (goto-char (point-min))
              (setq num 1)))))
    (setq num (1- num))))

(defun kom-next-link (num)
101
  "Move the cursor to the next active area in the LysKOM buffer."
102
103
  (interactive "p")
  (while (> num 0)
104
    (let ((where (next-single-property-change (point) 'lyskom-button-text)))
105
106
      (if where
          (progn
107
            (if (not (get-text-property where 'lyskom-button-text))
108
                (setq where (next-single-property-change where
109
                                                         'lyskom-button-text)))
110
111
112
113
114
115
116
            (if where
                (goto-char where)
              (goto-char (point-max))
              (setq num 1)))))
    (setq num (1- num))))


David Byers's avatar
X    
David Byers committed
117
(defun kom-button-press ()
118
  "Simulate a mouse button press at point."
119
  (interactive)
David Byers's avatar
X    
David Byers committed
120
  (lyskom-button-press (point)))
121

122
123
124
125
126
(defun kom-menu-button-press ()
  "Simulate a menu mouse button press at point."
  (interactive)
  (lyskom-button-menu (point) 'key))

David Byers's avatar
David Byers committed
127
128
129
130
(defun kom-button-click (event &optional do-default)
  "Execute the default action of the active area under the mouse.
If optional argument do-default is non-nil, call the default binding of
this-command-keys."
131
  (interactive "@e")
David Byers's avatar
David Byers committed
132
133
134
135
136
137
  (let* ((pos (event-point event))
         (glyph (event-glyph event))
         (widget (and pos 
                      (or (and glyph (glyph-property glyph 'widget))
                          (widget-at pos))))
         (parent (and widget (widget-get widget ':parent)))
David Byers's avatar
David Byers committed
138
139
140
         (href (or (and widget (widget-get widget ':href))
                   (and parent (widget-get parent ':href))
                   (and widget (widget-get widget 'href))
David Byers's avatar
David Byers committed
141
                   (and parent (widget-get parent 'href)))))
142
143
    (cond (href (require 'w3)
                (w3-widget-button-click event))
David Byers's avatar
David Byers committed
144
145
146
147
148
149
          ((and do-default
                (or (null pos)
                    (null (get-text-property pos 'lyskom-button-type))))
           (let ((fn (lookup-key global-map (this-command-keys))))
             (when (commandp fn)
               (call-interactively fn))))
David Byers's avatar
David Byers committed
150
151
          (t (lyskom-button-press pos)))))

David Byers's avatar
David Byers committed
152
153
154
155
156
157
(defun kom-button-click-or-yank (event)
  "Execute the default action of the active area under the mouse.
If there is no active area, then do something else."
  (interactive "@e")
  (kom-button-click event t))

David Byers's avatar
X    
David Byers committed
158
(defun kom-popup-menu (event)
159
160
  "Pop up a menu of actions to be taken at the active area under the mouse."
  (interactive "@e")
David Byers's avatar
David Byers committed
161
162
163
164
165
166
  (let* ((pos (event-point event))
         (glyph (event-glyph event))
         (widget (and pos 
                      (or (and glyph (glyph-property glyph 'widget))
                          (widget-at pos))))
         (parent (and widget (widget-get widget ':parent)))
David Byers's avatar
David Byers committed
167
168
169
         (href (or (and widget (widget-get widget ':href))
                   (and parent (widget-get parent ':href))
                   (and widget (widget-get widget 'href))
David Byers's avatar
David Byers committed
170
                   (and parent (widget-get parent 'href)))))
171
172
    (cond (href (require 'w3)
                (w3-popup-menu event))
David Byers's avatar
David Byers committed
173
174
175
          ((and pos (get-text-property pos 'lyskom-button-type))
           (lyskom-button-menu pos event))
          (t (lyskom-background-menu pos event)))))
David Kågedal's avatar
David Kågedal committed
176
  
David Kågedal's avatar
David Kågedal committed
177
178
(defun kom-mouse-null (event)
  "Do nothing."
179
  (interactive "@e")
David Kågedal's avatar
David Kågedal committed
180
  ;; This is here to pervent unwanted events when clicking mouse-3
181
  )
David Kågedal's avatar
David Kågedal committed
182

David Byers's avatar
X    
David Byers committed
183
(defun lyskom-make-button-menu (title entries buf arg text)
184
  "Create a menu keymap from a list of button actions."
David Kågedal's avatar
David Kågedal committed
185
186
187
  ;; Use the command as the event for simplicity.  Note that the menu
  ;; function alters the menu, so we copy the entries to prevent it
  ;; from fiddling with lyskom-button-actions.
David Byers's avatar
X    
David Byers committed
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
  (cond ((string-match "XEmacs" (emacs-version))
         (cons title 
               (mapcar (function
                        (lambda (entry)
                          (vector (car entry)
                                  (` ((, (cdr entry)) 
                                      (, buf)
                                      (, arg)
                                      (, text)))
                                  ':active t)))
                       entries)))
        (t (append (list 'keymap title)
                   (mapcar '(lambda (entry)
                              (cons (` ((, (cdr entry)) 
                                        (, buf)
                                        (, arg)
                                        (, text)))
                                    (copy-tree entry)))
                           entries)))))


209

David Kågedal's avatar
David Kågedal committed
210
(defun lyskom-button-menu (pos event)
David Byers's avatar
X    
David Byers committed
211
  "Internal function used by kom-popup-menu"
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
  (let* ((type  (get-text-property pos 'lyskom-button-type))
         (arg   (get-text-property pos 'lyskom-button-arg))
         (text  (get-text-property pos 'lyskom-button-text))
         (buf   (get-text-property pos 'lyskom-buffer))
         (data  (assq type lyskom-button-actions))
         (title (lyskom-format 
                 (lyskom-get-string
                  (or (intern-soft (concat (symbol-name type)
                                           "-popup-title"))
                      'generic-popup-title))
                 text))
         (actl  (or (and data (elt data 3)) nil)))
    (cond ((null data) (goto-char pos))
          ((null actl) (goto-char pos))
          ((null buf) (goto-char pos))
227
          ((null (get-buffer buf))
228
           (lyskom-message "%s" (lyskom-get-string 'no-such-buffer)))
229
230
231
          (t         
           (if (symbolp title) (setq title (lyskom-get-string title)))
           (set-buffer buf)
232
233
234
235
236

	   ;; There is a simple bug in x-popup-menu which causes menus
	   ;; from simple keymaps to be title-less. A list consisting
	   ;; of a single keymap works better. A patch is submittet to
	   ;; the GNU folks. /davidk
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
	   (if (eq event 'key)
	       (lyskom-keyboard-menu title actl buf arg text)
	     (let* ((menu (lyskom-make-button-menu title actl
						   buf arg text)))
	       (lyskom-do-popup-menu menu event)))))))


(defun lyskom-keyboard-menu-get-event (prompt)
  "Returns `prev', `next', `select', `cancel' or `help'."
  (lyskom-xemacs-or-gnu
   (let ((event (next-command-event nil prompt)))
     (if (eq (event-type event) 'key-press)
	 (cdr (assq (event-key event)
		    '((space . next)
		      (down . next)
		      (?n . next)
		      (?d . next)
		      (delete . prev)
		      (backspace . prev)
		      (up . prev)
		      (?p . prev)
		      (?u . prev)
		      (return . select)
		      (linefeed . select)
		      (escape . cancel)
		      (?q . cancel)
		      (?h . help))))
       ))
   (progn
     (lyskom-message "%s" prompt)
     (cdr (assq (read-event)
		'((32 . next)
		  (down . next)
		  (?n . next)
		  (?\C-n . next)
		  (?d . next)
		  (delete . prev)
		  (backspace . prev)
		  (up . prev)
		  (?p . prev)
		  (?\C-p . prev)
		  (?u . prev)
		  (return . select)
		  (linefeed . select)
		  (?\C-j . select)
		  (escape . cancel)
		  (?q . cancel)
		  (?\C-h . help))))
     )))
		  
(defun lyskom-keyboard-menu (title entries buf arg text)
  "Do a keyboard menu selection."
  (let ((cursor-in-echo-area t)
	(entry entries)
	(going t)
	prefix
	event)
    (let ((maxlen 0)
	  (e entries))
      (while e
	(if (> (length (car (car e))) maxlen)
	    (setq maxlen (length (car (car e)))))
	(setq e (cdr e)))
      (setq prefix (substring title 0
			      (min (length title)
				   (- (window-width (minibuffer-window))
				      maxlen 3)))))
    (while going
      (setq event (lyskom-keyboard-menu-get-event
		   (format "%s: %s" prefix (car (car entry)))))
      (cond
       ;; Next menu item
       ((eq event 'next)
	(setq entry (or (cdr entry) entries)))

       ;; Previous menu item
       ((eq event 'prev)
	(let ((e entries)
	      (l nil))
	  (while (and e (not (eq (cdr e) entry)))
	    (setq l e
		  e (cdr e)))
	  (setq entry (or e l))))
David Byers's avatar
X    
David Byers committed
320

321
322
323
324
325
       ;; Select
       ((eq event 'select)
	(if entry
	    (progn
	      (setq going nil)
326
	      (message nil)
327
	      (funcall (cdr (car entry)) buf arg text))))
David Byers's avatar
X    
David Byers committed
328

329
330
331
332
333
334
335
336
337
       ;; Help
       ((eq event 'help)
	(lyskom-keyboard-menu-get-event
	 (lyskom-get-string 'keyboard-menu-help)))
       
       ;; Escape
       ((eq event 'cancel)
	(setq going nil))))))
       
David Byers's avatar
X    
David Byers committed
338
339

(defun lyskom-button-press (pos)
340
  "Execute the default action of the active area at POS if any."
David Byers's avatar
David Byers committed
341
342
343
344
345
346
347
348
349
  (when pos
    (let* ((type (get-text-property pos 'lyskom-button-type))
           (arg  (get-text-property pos 'lyskom-button-arg))
           (text (get-text-property pos 'lyskom-button-text))
           (buf  (get-text-property pos 'lyskom-buffer))
           (hint (get-text-property pos 'lyskom-button-hint))
           (data (assq type lyskom-button-actions))
           (act  (or (and kom-use-button-hints hint)
                     (and data (elt data 2)))))
350
                 
David Byers's avatar
David Byers committed
351
352
353
354
355
356
357
358
359
      (cond ((null act) (goto-char pos))
            ((null buf) (goto-char pos))
            ((and buf (null (get-buffer buf))) 
             (lyskom-message "%s" (lyskom-get-string 'no-such-buffer)))
            (t (and buf (set-buffer buf))
               (funcall act
                        buf
                        arg
                        text))))))
360
                      
361

David Byers's avatar
David Byers committed
362
363
364
365
366
367
368
369
370
371
372
373
374
375
(defun lyskom-fix-pseudo-url (url)
  (save-match-data
    (if (not (string-match lyskom-url-protocol-regexp url))
        (cond ((string-match "^www\\." url) 
               (concat "http://" url))
              ((string-match "^ftp\\." url) 
               (concat "ftp://" url))
              ((string-match "^gopher\\." url) 
               (concat "gopher://" url))
              ((string-match "^wais\\." url)
               (concat "wais://" url))
              (t (concat "http://" url)))
      url)))

376

377
(defun lyskom-button-transform-text (text)
378
379
380
381
  "Add text properties to the string TEXT according to the definition of
lyskom-text-buttons. Returns the modified string."
  (let ((blist lyskom-text-buttons)
        (start 0)
382
        (el nil))
383
384
    (while blist
      (setq el (car blist))
David Kågedal's avatar
David Kågedal committed
385
      (setq start 0)
386
      (while (string-match (elt el 0) text start)
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
        (add-text-properties 
         (match-beginning (or (elt el 2) 0))
         (match-end (or (elt el 2) 0))
         (cond ((eq (elt el 1) 'text)
                (lyskom-generate-button 'text
                                        (lyskom-button-get-arg el text)
                                        (lyskom-button-get-text el text)
                                        (lyskom-button-get-face el)))
               ((eq (elt el 1) 'conf)
                (lyskom-generate-button 'conf
                                        (lyskom-button-get-arg el text)
                                        (lyskom-button-get-text el text)
                                        (lyskom-button-get-face el)))
               ((eq (elt el 1) 'pers)
                (lyskom-generate-button 'pers
                                        (lyskom-button-get-arg el text)
                                        (lyskom-button-get-text el text)
                                        (lyskom-button-get-face el)))
               ((eq (elt el 1) 'url)
                (lyskom-generate-button 'url
                                        nil
                                        (lyskom-button-get-text el text)
                                        (lyskom-button-get-face el)))
David Byers's avatar
David Byers committed
410
411
412
413
414
415
416
417
418

               ((eq (elt el 1) 'pseudo-url)
                (let ((url (lyskom-fix-pseudo-url
                            (lyskom-button-get-text el text))))
                  (lyskom-generate-button 'url
                                          nil
                                          url
                                          (lyskom-button-get-face el))))

419
420
421
422
423
424
 	       ((eq (elt el 1) 'info-node)
 		(lyskom-generate-button 'info-node
 					(lyskom-button-get-arg el text)
 					(lyskom-button-get-text el text)
 					(lyskom-button-get-face el)))
               
425
426
427
428
429
               ((eq (elt el 1) 'email)
                (lyskom-generate-button 'email
                                        nil
                                        (lyskom-button-get-text el text)
                                        (lyskom-button-get-face el)))
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
               (t nil))
         text)
        (setq start (match-end 0)))
      (setq blist (cdr blist))))
  text)

(defun lyskom-button-get-arg (el text)
  "Get the button argument for button type EL from TEXT according to
the current match-data."
  (let ((no (or (elt el 3) 0)))
    (substring text (match-beginning no) (match-end no))))

(defun lyskom-button-get-text (el text)
  "Get the button text for button type EL from TEXT according to
the current match-data."
  (let ((no (or (elt el 2) 0)))
    (substring text (match-beginning no) (match-end no))))

(defun lyskom-button-get-face (el)
  "Get the button face for button type EL from TEXT according to
the current match-data."
David Byers's avatar
David Byers committed
451
  (elt el 4))
452

453

454
455
456
457
458
459
460
461
462
463
464
465
466
467
(defun lyskom-get-button-hint (hints)
  "Get the hint to be used right now (if any) from HINTS"
  (let ((result nil)
        (hint nil))
    (while (and hints (null result))
      (setq hint (car hints))
      (setq hints (cdr hints))
      (cond ((null (car hint)) 
             (if (and (eq lyskom-current-function
                          (elt hint 1))
                      (or (null (elt hint 2))
                          (eq lyskom-current-function-phase
                              (elt hint 2))))
                 (setq result (elt hint 3))))
David Byers's avatar
X    
David Byers committed
468
469
470
471
472
473
474
475
476
            ((listp (car hint))
             (if (and lyskom-executing-command
                      (memq lyskom-current-command (car hint)))
                 (setq result (cdr hint))))
            ((symbolp (car hint))
             (if (and lyskom-executing-command
                      lyskom-current-command
                      (eq lyskom-current-command (car hint)))
                 (setq result (cdr hint))))))
477
478
479
    result))


480
	
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
(defun lyskom-generate-button (type arg &optional text face)
  "Generate the properties for a button of type TYPE with argument ARG.
Optional argument TEXT is the button text to be saved as a property and
FACE is the default text face for the button."
  (let* ((persno (cond ((boundp 'lyskom-pers-no) lyskom-pers-no)
                       ((and (boundp 'lyskom-buffer) lyskom-buffer)
                        (save-excursion
                          (set-buffer lyskom-buffer)
                          lyskom-pers-no))
                       (t -1)))
         (numarg (cond ((numberp arg) arg)
                       ((stringp arg) (string-to-number arg))
                       (t nil)))
         (data (assq type lyskom-button-actions))
         (hints (and data (elt data 4)))
496
         (the-hint (lyskom-get-button-hint hints))
497
498
499
500
501
502
         (props 
          (cond ((and (or (eq type 'conf) 
                          (eq type 'pers))
                      numarg)
                 (list 'face 
                       (or face
David Byers's avatar
David Byers committed
503
504
505
                           (cond ((eq persno numarg) 'kom-me-face)
                                 ((memq numarg kom-friends) 'kom-friends-face)
                                 (t 'kom-active-face)))
506
507
508
509
510
511
                       'mouse-face 'kom-highlight-face
                       'lyskom-button-text text
                       'lyskom-button-type type
                       'lyskom-button-arg numarg
                       'lyskom-buffer lyskom-buffer))
                ((and (eq type 'text) numarg)
David Byers's avatar
David Byers committed
512
                 (list 'face (or face 'kom-text-no-face)
513
514
515
516
517
518
519
520
521
522
                       'mouse-face 'kom-highlight-face
                       'lyskom-button-text text
                       'lyskom-button-type type
                       'lyskom-button-arg numarg
                       'lyskom-buffer lyskom-buffer))
                ((eq type 'url)
                 (list 'face (or face 'kom-active-face)
                       'mouse-face 'kom-highlight-face
                       'lyskom-button-text text
                       'lyskom-button-type type
523
                       'lyskom-button-arg arg
524
                       'lyskom-buffer lyskom-buffer))
525
526
527
528
529
530
531
                (t
		 (list 'face (or face 'kom-active-face)
		       'mouse-face 'kom-highlight-face
		       'lyskom-button-text text
		       'lyskom-button-type type
		       'lyskom-button-arg arg
		       'lyskom-buffer lyskom-buffer)))))
532

533
534
535
536
537
    (append (list 'rear-nonsticky t)
	    (if the-hint
		(cons 'lyskom-button-hint
		      (cons the-hint props))
	      props))))
538
539
540
      
        
           
541
542

(defun lyskom-default-button (type arg)
543
544
545
  "Generate a button of type TYPE from data in ARG. ARG can be almost any
type of data and is converted to the proper argument type for buttons of
type TYPE before being send to lyskom-generate-button."
David Kågedal's avatar
David Kågedal committed
546
547
548
549
550
551
552
553
  (and kom-text-properties
       (let (xarg text)
	 (cond ((eq type 'conf)
		(cond ((lyskom-conf-stat-p arg)
		       (if (conf-type->letterbox (conf-stat->conf-type arg))
			   (setq type 'pers))
		       (setq xarg (conf-stat->conf-no arg)
			     text (conf-stat->name arg)))
554
555
556
557
558
559
560
561
562
563
		      ((numberp arg)
                       (if (setq xarg (cache-get-conf-stat arg))
                           (progn
                             (if (conf-type->letterbox
                                  (conf-stat->conf-type xarg))
                                 (setq type 'pers))
                             (setq text (conf-stat->name xarg))
                             (setq xarg (conf-stat->conf-no xarg)))
                         (setq text ""
                               xarg arg)))
David Kågedal's avatar
David Kågedal committed
564
565
566
567
568
569
570
		      (t (setq text "" xarg 0))))
	       ((eq type 'pers)
		(cond ((lyskom-conf-stat-p arg)
		       (setq xarg (conf-stat->conf-no arg)
			     text (conf-stat->name arg)))
		      ((lyskom-pers-stat-p arg)
		       (setq xarg (pers-stat->pers-no arg)
571
572
573
574
575
576
577
578
579
580
581
			     text 
                             (or (conf-stat->name
                                  (cache-get-conf-stat
                                   (pers-stat->pers-no arg)))
                                 "")))
		      ((numberp arg) 
                       (setq text
                             (or (conf-stat->name
                                  (cache-get-conf-stat arg))
                                 "")
                             xarg arg))
David Kågedal's avatar
David Kågedal committed
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
		      (t (setq text "" xarg 0))))
	       ((eq type 'text)
		(cond ((stringp arg) (setq xarg (string-to-number arg)
					   text arg))
		      ((numberp arg) (setq xarg arg
					   text (number-to-string arg)))
		      ((lyskom-text-stat-p arg)
		       (setq xarg (text-stat->text-no arg)
			     text (number-to-string (text-stat->text-no arg))))
		      (t (setq xarg 0 text ""))))
	       ((eq type 'url)
		(cond ((stringp arg) (setq xarg nil text arg))
		      (t (setq xarg nil text ""))))
	       (t (setq xarg arg text "")))
	 (lyskom-generate-button type xarg text nil))))
597
598
599
600
                  

           

601
602
603
604
605

;;;========================================
;;; Button actions
;;;

David Byers's avatar
X    
David Byers committed
606

607
608
609
610
611
612
(defun lyskom-button-view-text (buf arg text)
  "In the LysKOM buffer BUF, view the text ARG. Last argument TEXT is ignored.
This is a LysKOM button action."
  (cond ((not (integerp arg)) nil)
        (t (pop-to-buffer buf)
           (kom-view arg))))
David Byers's avatar
David Byers committed
613

David Byers's avatar
David Byers committed
614
615
616
617
618
619
(defun lyskom-button-review-noconversion (buf arg text)
  "In the LysKOM buffer BUF, view the text ARG without conversion. 
Last argument TEXT is ignored. This is a LysKOM button action."
  (cond ((not (integerp arg)) nil)
        (t (pop-to-buffer buf)
           (kom-review-noconversion arg))))
David Byers's avatar
David Byers committed
620
621
622
623
624
625
626
627
628
629
630
631
632
633

(defun lyskom-button-review-tree (buf arg text)
  "In the LysKOM buffer BUF, view the text ARG. Last argument TEXT is ignored.
This is a LysKOM button action."
  (cond ((not (integerp arg)) nil)
	(t (pop-to-buffer buf)
	   (kom-review-tree arg))))

(defun lyskom-button-find-root (buf arg text)
  "In the LysKOM buffer BUF, view the text ARG. Last argument TEXT is ignored.
This is a LysKOM button action."
  (cond ((not (integerp arg)) nil)
	(t (pop-to-buffer buf)
	   (kom-find-root arg))))
634

635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
(defun lyskom-button-comment-text (buf arg text)
  "In the LysKOM buffer BUF, comment the text ARG. Last argument TEXT is ignored.
This is a LysKOM button action."
  (cond ((not (integerp arg)) nil)
        (t (pop-to-buffer buf)
           (kom-write-comment arg))))

(defun lyskom-button-private-comment-text (buf arg text)
  "In the LysKOM buffer BUF, write a private comment the text ARG. 
Last argument TEXT is ignored.
This is a LysKOM button action."
  (cond ((not (integerp arg)) nil)
        (t (pop-to-buffer buf)
           (kom-private-answer arg))))

(defun lyskom-button-mark-text (buf arg text)
  "In the LysKOM buffer BUF, mark the text ARG. Last argument TEXT is ignored.
This is a LysKOM button action."
  (cond ((not (integerp arg)) nil)
        (t (unwind-protect
               (progn
                 (pop-to-buffer buf)
                 (lyskom-start-of-command 'kom-mark-text)
David Byers's avatar
David Byers committed
658
                 (lyskom-mark-text arg nil))
659
660
661
662
663
664
665
666
667
668
             (lyskom-end-of-command)))))

(defun lyskom-button-unmark-text (buf arg text)
  "In the LysKOM buffer BUF, unmark the text ARG. Last argument TEXT is ignored.
This is a LysKOM button action."
  (cond ((not (integerp arg)) nil)
        (t (unwind-protect
               (progn
                 (pop-to-buffer buf)
                 (lyskom-start-of-command 'kom-unmark-text)
David Byers's avatar
David Byers committed
669
                 (lyskom-unmark-text arg nil))
670
671
             (lyskom-end-of-command)))))
  
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
(defun lyskom-button-view-conf-presentation (buf arg text)
  "In the LysKOM buffer BUF, view the presentation of ARG. 
Last argument TEXT is ignored.
This is a LysKOM button action."
  (cond ((not (integerp arg)) nil)
        (t (pop-to-buffer buf)
           (kom-review-presentation arg))))

(defun lyskom-button-view-conf-status (buf arg text)
  "In the LysKOM buffer BUF, view the status of conference ARG. Last argument
TEXT is ignored.
This is a LysKOM button action."
  (cond ((not (integerp arg)) nil)
        (t (pop-to-buffer buf)
           (kom-status-conf arg))))

(defun lyskom-button-goto-conf (buf arg text)
  "In the LysKOM buffer BUF, go to the conference ARG. Last argument TEXT is
ignored.
This is a LysKOM button action."
  (cond ((not (integerp arg)) nil)
        (t (pop-to-buffer buf)
           (kom-go-to-conf arg))))

(defun lyskom-button-add-self (buf arg text)
  "In the LysKOM buffer buf, add self to conference ARG."
  (cond ((not (integerp arg)) nil)
        (t (pop-to-buffer buf)
           (kom-add-self arg))))

(defun lyskom-button-sub-self (buf arg text)
  "In the LysKOM buffer buf, sub self from conference ARG."
  (cond ((not (integerp arg)) nil)
        (t (pop-to-buffer buf)
           (kom-sub-self arg))))

(defun lyskom-button-view-pers-presentation (buf arg text)
  "In the LysKOM buffer BUF, view the presentation of person ARG. 
Last argument TEXT is ignored.
This is a LysKOM button action."
  (lyskom-button-view-conf-presentation buf arg text))

(defun lyskom-button-view-pers-status (buf arg text)
  "In the LysKOM buffer BUF, view the status of person ARG. 
Last argument TEXT is ignored.
This is a LysKOM button action."
  (cond ((not (integerp arg)) nil)
        (t (pop-to-buffer buf)
           (kom-status-person arg))))

(defun lyskom-button-mail (buf arg text)
  "In the LysKOM buffer BUF, send mail to the conference ARG.
Last argument TEXT is ignored.
This is a LysKOM button action."
  (cond ((not (integerp arg)) nil)
        (t (pop-to-buffer buf)
           (kom-send-letter arg))))

(defun lyskom-button-send-message (buf arg text)
  "In the LysKOM buffer BUF, send a personal message to person ARG."
  (cond ((not (integerp arg)) nil)
        (t (pop-to-buffer buf)
           (kom-send-message arg nil))))

737
738
739
740
741
742
743
744
(defun lyskom-button-copy-email (but arg text)
  "In the LysKOM buffer BUF, ignore ARG and copy TEXT to the kill ring.
This is a LysKOM button action."
  (kill-new text))

(defun lyskom-button-open-email (but arg text)
  "In the LysKOM buffer BUF, ignore ARG and open TEXT as an e-mail address.
This is a LysKOM button action."
745
746
747
  (if (fboundp 'compose-mail)
      (compose-mail text)
    (mail nil text)))
748

749
750
751
(defun lyskom-button-copy-url (but arg text)
  "In the LysKOM buffer BUF, ignore ARG and copy TEXT to the kill ring.
This is a LysKOM button action."
David Byers's avatar
X    
David Byers committed
752
  (kill-new (replace-in-string text "\\s-+" "")))
753
754
755
756
757


(defun lyskom-button-open-url (buf arg text)
  "In the LysKOM buffer BUF, ignore ARG and open TEXT as an URL.
This is a LysKOM button action."
David Byers's avatar
David Byers committed
758
  (let* ((url (lyskom-fix-pseudo-url (replace-in-string text "\\s-+" "")))
759
760
         protocol
         url-manager)
David Byers's avatar
David Byers committed
761
762
    (string-match lyskom-url-protocol-regexp url)
    (setq protocol (match-string 1 url))
763
764
765
    (setq url-manager (lyskom-get-url-manager protocol))
    (if (null url-manager)
        (lyskom-error "Can't find URL viewer"))
766
    (goto-char (point-max))
767
    (funcall (elt url-manager 3) url url-manager)))
768

769
770
771
772
773
 
 
;;;
;;;	Info node button
;;;
774

775
776
777
778
779
780
781
782
783
784
785
(defun lyskom-button-goto-info-node (buf arg text)
  "In the LysKOM buffer BUF, open ARG as an Info node, and ignore TEXT.
This is a LysKOM button action."
  (when (not (fboundp 'Info-goto-node))
    (autoload 'Info-goto-node "info"
      "Go to info node named NAME.  Give just NODENAME or (FILENAME)NODENAME."
      t))
  (setq arg (replace-in-string arg "\n" " " t))
  (setq arg (replace-in-string arg " +" " " t))
  (Info-goto-node arg))
 
786
787
788
789
790
791

;;;
;;;	LysKOM URL Management
;;;

(defun lyskom-get-url-manager (protocol)
792
  "Get the URL manager for PROTOCOL (a string). Returns a function."
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
  (let ((managers kom-url-managers)
	(preferences kom-url-viewer-preferences)
	(result nil))
    (while (and preferences (not result))
      (setq managers kom-url-managers)
      (while (and managers (not result))
	(if (and (string-match (car (car managers))
			       (car preferences))
		 (string-match (car (cdr (car managers)))
			       protocol))
	    (setq result (car managers)))
	(setq managers (cdr managers)))
      (setq preferences (cdr preferences)))
    result))



(defun lyskom-url-manager-starting (manager)
811
  "Tell the user that the URL manager MANAGER is starting."
812
  (lyskom-message "%s" (lyskom-format (lyskom-get-string 'starting-program)
813
814
815
				 (elt manager 2))))


David Byers's avatar
David Byers committed
816
817
(eval-when-compile (defvar browse-url-browser-function nil))

David Byers's avatar
X    
David Byers committed
818
819
820
821
(defun lyskom-view-url-browse-url (url manager)
  (require 'browse-url)
  (funcall browse-url-browser-function url))

822
(defun lyskom-view-url-w3 (url manager)
823
  "View the URL URL using W3. Second argument MANAGER is ignored."
824
825
826
  (w3-fetch url))

(defun lyskom-view-url-dired (url manager)
827
  "View the URL URL using dired. Second argument MANAGER is ignored."
828
829
830
831
832
833
834
835
836
837
  (if (not (and (string-match
		 "\\(file\\|ftp\\)://\\([^/:]*\\)\\(:[0-9]*\\)?\\(/\\|$\\)"
		 url)
		(match-beginning 0)
		(match-beginning 1)
		(match-beginning 2)))
      (lyskom-error "Bad URL"))
  (let ((host (substring url (match-beginning 2) (match-end 2)))
	(path (substring url (match-end 0)))
	(user "anonymous"))
David Byers's avatar
David Byers committed
838
839
    (if  (string-match ";type=.$" path)
        (setq path (substring path 0 (match-beginning 0))))
840
841
842
843
844
    (if (and (string-match "\\([^@]*\\)@" host)
	     (match-beginning 1))
	(progn
	  (setq user (substring host (match-beginning 1) (match-end 1)))
	  (setq host (substring host (match-end 0)))))
David Byers's avatar
David Byers committed
845
846
847
848
    (cond ((string= host "localhost") (find-file path))
          (t (find-file (concat "/" user "@" host ":/" path))))
    ;;    (message "%s  %s  %s" user host path)
    ))
849
850


851

852
(defun lyskom-view-url-telnet (url manager)
853
  "View the URL URL using telnet. Second argument MANAGER is ignored."
854
  (if (not (and (string-match 
David Byers's avatar
David Byers committed
855
                 "telnet://\\([^@]*@\\)?\\([^/:]*\\)\\(:[0-9]*\\)?"
856
857
858
859
860
861
862
863
		 url)
		(match-beginning 0)
		(match-beginning 2)))
      (lyskom-error "Bad URL"))
  (let ((host (substring url (match-beginning 2) (match-end 2)))
	(port (if (match-beginning 3)
		  (substring url (1+ (match-beginning 3)) (match-end 3))
		""))
David Byers's avatar
David Byers committed
864
865
866
	(user (if (match-beginning 1)
                  (substring url (match-beginning 1) (1- (match-end 1)))
                nil))
867
868
        ;; (password nil)
	)
David Byers's avatar
David Byers committed
869
870
    (if (and user
             (string-match "^\\([^:]*\\):\\(.*\\)" user))
871
872
873
874
875
876
877
878
        (progn
	  ;; (setq password (substring user
	  ;; 			    (match-beginning 2)
	  ;; 			    (match-end 2)))
	  (setq user (substring user 
				(match-beginning 1)
				(match-end 1)))))
    
David Byers's avatar
David Byers committed
879
    (telnet (concat host " " port))
880
881
882
883
884
    ;;    (message "u:%s  p:%s  h:%s  #:%s" 
    ;;             (or user "<u>")
    ;;             (or password "<p>")
    ;;             (or host "<h>")
    ;;             (or port "<#>"))
David Byers's avatar
David Byers committed
885
886

    ))
887

888

889
(defun lyskom-view-url-mailmode (url manager)
890
  "View the URL URL using mail in Emacs. The second argument MANAGER is ignored."
891
892
893
894
895
896
897
  (if (not (and (string-match "mailto:\\([^@]+@.*\\)$" url)
		(match-beginning 1)))
      (lyskom-error "Bad URL"))
  (mail nil (substring url (match-beginning 1) (match-end 1))))


(defun lyskom-view-url-netscape (url manager)
898
899
900
901
902
  "View the URL URL using Netscape Navigator. The second argument
MANAGER is the URL manager that started Netscape.

This function attempts to load the URL in a running Netscape, but failing
that, starts a new one."
David Byers's avatar
David Byers committed
903
  (setq url (replace-in-string url "," "%2C"))
904
905
906
907
908
909
  (let* ((url-string (if (eq window-system 'win32)
                         (list url)
                       (list "-remote"
                             (format "openUrl(%s)" url))))
         
         (proc (apply 'start-process "netscape"
David Byers's avatar
David Byers committed
910
911
912
913
914
915
                      nil
                      (if (listp kom-netscape-command)
                          (car kom-netscape-command)
                        kom-netscape-command)
                      (if (listp kom-netscape-command)
                          (append (cdr kom-netscape-command)
916
917
                                  url-string)
                        url-string)))
918
919
920
921
922
923
924
925
926
         (status 'run)
         (exit nil))
    (lyskom-url-manager-starting manager)
    (while (eq status 'run)
      (accept-process-output)
      (setq status (process-status proc)))
    (setq exit (process-exit-status proc))
    (cond ((and (eq status 'exit) 
                (eq exit 1))
David Byers's avatar
David Byers committed
927
           (apply 'start-process "netscape"
928
                          nil
David Byers's avatar
David Byers committed
929
930
931
932
933
934
935
                          (if (listp kom-netscape-command)
                              (car kom-netscape-command)
                            kom-netscape-command)
                          (if (listp kom-netscape-command)
                              (append (cdr kom-netscape-command)
                                      (list url))
                            (list url))))
936
          (t nil))))
937
938
939


(defun lyskom-view-url-mosaic (url manager)
940
941
  "View the URL URL using NCSA Mosaic. The attempts to open the URL in an
existing Mosaic process. Failing that, it starts a new Mosaic."
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
  (let ((pid -1)
        tempbuffer
        (filename "/tmp/Mosaic."))
    (if (file-exists-p (expand-file-name "~/.mosaicpid"))
        (save-excursion
          (set-buffer 
           (setq tempbuffer (get-buffer-create " *kom*-mosaicpid")))
          (insert-file-contents (expand-file-name "~/.mosaicpid"))
          (setq pid (read tempbuffer))
          (delete-region (point-min) (point-max))
          (insert "newwin\n")
          (insert url)
          (insert "\n")
          (setq filename (concat filename (number-to-string pid)))
          (write-region (point-min) (point-max) filename nil 'x)
          (kill-buffer tempbuffer)
          (if (= -1 (signal-process pid 30))
David Byers's avatar
David Byers committed
959
960
961
962
963
964
965
966
967
              (apply 'start-process "mosaic"
                     (current-buffer)
                     (if (listp kom-mosaic-command)
                         (car kom-mosaic-command)
                       kom-mosaic-command )
                     (if (listp kom-mosaic-command)
                         (append (cdr kom-mosaic-command)
                                 (list url))
                       (list url)))
968
969
	    (lyskom-url-manager-starting manager)))
      (save-excursion
David Byers's avatar
David Byers committed
970
971
972
973
974
975
976
977
978
        (apply 'start-process "mosaic"
               (current-buffer)
               (if (listp kom-mosaic-command)
                   (car kom-mosaic-command)
                 kom-mosaic-command )
               (if (listp kom-mosaic-command)
                   (append (cdr kom-mosaic-command)
                           (list url))
                 (list url)))
979
980
	(lyskom-url-manager-starting manager)))))

Peter Liljenberg's avatar
Peter Liljenberg committed
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
;; Added by Peter Liljenberg
(defun lyskom-view-url-lynx (url manager)
  "View the URL URL using Lynx.
Lynx will be run either in an xterm or in Emacs terminal mode,
depending on the value of `kom-lynx-terminal'."
  (cond
   ((eq kom-lynx-terminal 'xterm)
    (apply 'start-process
	   "lynx"
	   nil
	   (car kom-lynx-xterm-command)
	   (append (cdr kom-lynx-xterm-command) (list url)))
    (lyskom-url-manager-starting manager))

   ((eq kom-lynx-terminal 'terminal)
    (let* ((lbuf (get-buffer "*Lynx*"))
	   (lproc (and lbuf (get-buffer-process lbuf))))
      (if lproc
	  ;; Tell existing Lynx to fetch URL
	  (process-send-string lproc (concat "g" url "\n"))

	;; Create a new Lynx
	(switch-to-buffer
	 (apply 'make-term "Lynx"
		(if (listp kom-lynx-terminal-command)
		    (car kom-lynx-terminal-command)
		  kom-lynx-terminal-command)
		nil
		(if (listp kom-lynx-terminal-command)
		    (append (cdr kom-lynx-terminal-command) (list url))
		  (list url))))
	(delete-other-windows)
	(term-char-mode)
	(set-process-sentinel
	 (get-buffer-process (current-buffer))
	 (function (lambda (proc str)
		     (kill-buffer (process-buffer proc))))))
      (lyskom-url-manager-starting manager)))

   (t (lyskom-error "Bad Lynx terminal: %s" kom-lynx-terminal))
   ))
1022

David Kågedal's avatar
David Kågedal committed
1023
1024
1025
;;;
;;;	email buttons
;;;
1026

David Kågedal's avatar
David Kågedal committed
1027
1028
(defun lyskom-button-send-mail (to)
  (mail nil to))
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104

;;;
;;;     aux-item buttons
;;;

(defun lyskom-button-delete-aux (bug arg text)
  (let ((aux nil))
    (cond ((aux-item-p arg))
          ((listp arg)
           (let ((items (cond ((eq 'text (car arg))
                               (text-stat->aux-items 
                                (blocking-do 'get-text-stat (elt arg 1))))
                              ((eq 'conf (car arg))
                               (conf-stat->aux-items 
                                (blocking-do 'get-conof-stat (elt arg 1))))
                              (t nil))))
             (while items
               (when (eq (aux-item->aux-no (car items)) (elt arg 2))
                 (setq aux (car items))
                 (setq items nil))
               (setq items (cdr items))))))

    (when aux
      (lyskom-start-of-command nil)
      (unwind-protect
          (progn
            (if (blocking-do (cond ((eq 'text (car arg)) 'modify-text-info)
                                   ((eq 'conf (car arg)) 'modify-conf-info))
                             (elt arg 1)
                             (list (aux-item->aux-no aux))
                             nil)
                (cond ((eq 'text (car arg)) (cache-del-text-stat (elt arg 1)))
                      ((eq 'conf (car arg)) (cache-del-conf-stat (elt arg 1))))
              (lyskom-report-command-answer nil)))
        (lyskom-end-of-command)))))
          

(defun lyskom-button-info-aux (buf arg text)
  (pop-to-buffer buf)
  (let ((aux nil))
    (cond ((aux-item-p arg))
          ((listp arg) 
           (let ((items (cond ((eq 'text (car arg))
                               (text-stat->aux-items 
                                (blocking-do 'get-text-stat (elt arg 1))))
                              ((eq 'conf (car arg))
                               (conf-stat->aux-items 
                                (blocking-do 'get-conof-stat (elt arg 1))))
                              (t nil))))
             (while items
               (when (eq (aux-item->aux-no (car items)) (elt arg 2))
                 (setq aux (car items))
                 (setq items nil))
               (setq items (cdr items))))))
              
    (if aux
        (progn
          (lyskom-start-of-command nil)
          (unwind-protect
              (let ((data (lyskom-aux-item-definition-call 
                           aux
                           'info 
                           aux
                           (cond ((eq 'text (car arg)) 
                                  (lyskom-format 'text-no (elt arg 1)))
                                 ((eq 'conf (car arg))
                                  (lyskom-format 'conference-no
                                                 (blocking-do 'get-conf-stat
                                                              (elt arg 1))))
                                 (t "????")))))
                (if data
                    (lyskom-insert data)
                  (lyskom-format-insert 'aux-item-no-info)))
            (lyskom-end-of-command)))
      (lyskom-format-insert 'cant-get-aux-item))))