Mercurial > emacs
comparison lisp/net/eudc.el @ 42569:df3f717a3933
(top-level): Use eudc-xemacs-p instead of string-match on emacs-version
again.
author | Pavel Janík <Pavel@Janik.cz> |
---|---|
date | Sun, 06 Jan 2002 15:06:14 +0000 |
parents | e33d394fe874 |
children | 24c994803548 |
comparison
equal
deleted
inserted
replaced
42568:049f9a72129f | 42569:df3f717a3933 |
---|---|
83 (defvar eudc-server-hotlist nil) | 83 (defvar eudc-server-hotlist nil) |
84 | 84 |
85 ;; List of variables that have server- or protocol-local bindings | 85 ;; List of variables that have server- or protocol-local bindings |
86 (defvar eudc-local-vars nil) | 86 (defvar eudc-local-vars nil) |
87 | 87 |
88 ;; Protocol local. Query function | 88 ;; Protocol local. Query function |
89 (defvar eudc-query-function nil) | 89 (defvar eudc-query-function nil) |
90 | 90 |
91 ;; Protocol local. A function that retrieves a list of valid attribute names | 91 ;; Protocol local. A function that retrieves a list of valid attribute names |
92 (defvar eudc-list-attributes-function nil) | 92 (defvar eudc-list-attributes-function nil) |
93 | 93 |
193 (concat rtn-str | 193 (concat rtn-str |
194 (substring str prev-start match) | 194 (substring str prev-start match) |
195 newtext))) | 195 newtext))) |
196 (concat rtn-str (substring str start)))) | 196 (concat rtn-str (substring str start)))) |
197 | 197 |
198 ;;}}} | 198 ;;}}} |
199 | 199 |
200 ;;{{{ Server and Protocol Variable Routines | 200 ;;{{{ Server and Protocol Variable Routines |
201 | 201 |
202 (defun eudc-server-local-variable-p (var) | 202 (defun eudc-server-local-variable-p (var) |
203 "Return non-nil if VAR has server-local bindings." | 203 "Return non-nil if VAR has server-local bindings." |
228 (plist-put eudc-locals 'protocol protocol-locals)) | 228 (plist-put eudc-locals 'protocol protocol-locals)) |
229 (put var 'eudc-locals eudc-locals) | 229 (put var 'eudc-locals eudc-locals) |
230 (add-to-list 'eudc-local-vars var) | 230 (add-to-list 'eudc-local-vars var) |
231 (unless protocol | 231 (unless protocol |
232 (eudc-update-variable var)))) | 232 (eudc-update-variable var)))) |
233 | 233 |
234 (defun eudc-server-set (var val &optional server) | 234 (defun eudc-server-set (var val &optional server) |
235 "Set the SERVER-local binding of VAR to VAL. | 235 "Set the SERVER-local binding of VAR to VAL. |
236 If omitted SERVER defaults to the current value of `eudc-server'. | 236 If omitted SERVER defaults to the current value of `eudc-server'. |
237 The current binding of VAR is changed only if SERVER is omitted." | 237 The current binding of VAR is changed only if SERVER is omitted." |
238 (if (eq 'unbound (eudc-variable-default-value var)) | 238 (if (eq 'unbound (eudc-variable-default-value var)) |
239 (eudc-default-set var (symbol-value var))) | 239 (eudc-default-set var (symbol-value var))) |
240 (let* ((eudc-locals (get var 'eudc-locals)) | 240 (let* ((eudc-locals (get var 'eudc-locals)) |
241 (server-locals (eudc-plist-get eudc-locals 'server))) | 241 (server-locals (eudc-plist-get eudc-locals 'server))) |
242 (setq server-locals (plist-put server-locals (or server | 242 (setq server-locals (plist-put server-locals (or server |
243 eudc-server) val)) | 243 eudc-server) val)) |
244 (setq eudc-locals | 244 (setq eudc-locals |
245 (plist-put eudc-locals 'server server-locals)) | 245 (plist-put eudc-locals 'server server-locals)) |
246 (put var 'eudc-locals eudc-locals) | 246 (put var 'eudc-locals eudc-locals) |
247 (add-to-list 'eudc-local-vars var) | 247 (add-to-list 'eudc-local-vars var) |
248 (unless server | 248 (unless server |
249 (eudc-update-variable var)))) | 249 (eudc-update-variable var)))) |
250 | 250 |
251 | 251 |
252 (defun eudc-set (var val) | 252 (defun eudc-set (var val) |
253 "Set the most local (server, protocol or default) binding of VAR to VAL. | 253 "Set the most local (server, protocol or default) binding of VAR to VAL. |
254 The current binding of VAR is also set to VAL" | 254 The current binding of VAR is also set to VAL" |
255 (cond | 255 (cond |
256 ((not (eq 'unbound (eudc-variable-server-value var))) | 256 ((not (eq 'unbound (eudc-variable-server-value var))) |
257 (eudc-server-set var val)) | 257 (eudc-server-set var val)) |
258 ((not (eq 'unbound (eudc-variable-protocol-value var))) | 258 ((not (eq 'unbound (eudc-variable-protocol-value var))) |
259 (eudc-protocol-set var val)) | 259 (eudc-protocol-set var val)) |
260 (t | 260 (t |
279 (if (not (and (boundp var) | 279 (if (not (and (boundp var) |
280 eudc-locals | 280 eudc-locals |
281 (eudc-plist-member eudc-locals 'protocol))) | 281 (eudc-plist-member eudc-locals 'protocol))) |
282 'unbound | 282 'unbound |
283 (setq protocol-locals (eudc-plist-get eudc-locals 'protocol)) | 283 (setq protocol-locals (eudc-plist-get eudc-locals 'protocol)) |
284 (eudc-lax-plist-get protocol-locals | 284 (eudc-lax-plist-get protocol-locals |
285 (or protocol | 285 (or protocol |
286 eudc-protocol) 'unbound)))) | 286 eudc-protocol) 'unbound)))) |
287 | 287 |
288 (defun eudc-variable-server-value (var &optional server) | 288 (defun eudc-variable-server-value (var &optional server) |
289 "Return the value of VAR local to SERVER. | 289 "Return the value of VAR local to SERVER. |
304 "Set the value of VAR according to its locals. | 304 "Set the value of VAR according to its locals. |
305 If the VAR has a server- or protocol-local value corresponding | 305 If the VAR has a server- or protocol-local value corresponding |
306 to the current `eudc-server' and `eudc-protocol' then it is set | 306 to the current `eudc-server' and `eudc-protocol' then it is set |
307 accordingly. Otherwise it is set to its EUDC default binding" | 307 accordingly. Otherwise it is set to its EUDC default binding" |
308 (let (val) | 308 (let (val) |
309 (cond | 309 (cond |
310 ((not (eq 'unbound (setq val (eudc-variable-server-value var)))) | 310 ((not (eq 'unbound (setq val (eudc-variable-server-value var)))) |
311 (set var val)) | 311 (set var val)) |
312 ((not (eq 'unbound (setq val (eudc-variable-protocol-value var)))) | 312 ((not (eq 'unbound (setq val (eudc-variable-protocol-value var)))) |
313 (set var val)) | 313 (set var val)) |
314 ((not (eq 'unbound (setq val (eudc-variable-default-value var)))) | 314 ((not (eq 'unbound (setq val (eudc-variable-default-value var)))) |
332 | 332 |
333 | 333 |
334 ;; Add PROTOCOL to the list of supported protocols | 334 ;; Add PROTOCOL to the list of supported protocols |
335 (defun eudc-register-protocol (protocol) | 335 (defun eudc-register-protocol (protocol) |
336 (unless (memq protocol eudc-supported-protocols) | 336 (unless (memq protocol eudc-supported-protocols) |
337 (setq eudc-supported-protocols | 337 (setq eudc-supported-protocols |
338 (cons protocol eudc-supported-protocols)) | 338 (cons protocol eudc-supported-protocols)) |
339 (put 'eudc-protocol 'custom-type | 339 (put 'eudc-protocol 'custom-type |
340 `(choice :menu-tag "Protocol" | 340 `(choice :menu-tag "Protocol" |
341 ,@(mapcar (lambda (s) | 341 ,@(mapcar (lambda (s) |
342 (list 'string ':tag (symbol-name s))) | 342 (list 'string ':tag (symbol-name s))) |
343 eudc-supported-protocols)))) | 343 eudc-supported-protocols)))) |
344 (or (memq protocol eudc-known-protocols) | 344 (or (memq protocol eudc-known-protocols) |
345 (setq eudc-known-protocols | 345 (setq eudc-known-protocols |
346 (cons protocol eudc-known-protocols)))) | 346 (cons protocol eudc-known-protocols)))) |
350 "Translate attribute names of QUERY. | 350 "Translate attribute names of QUERY. |
351 The translation is done according to | 351 The translation is done according to |
352 `eudc-protocol-attributes-translation-alist'." | 352 `eudc-protocol-attributes-translation-alist'." |
353 (if eudc-protocol-attributes-translation-alist | 353 (if eudc-protocol-attributes-translation-alist |
354 (mapcar '(lambda (attribute) | 354 (mapcar '(lambda (attribute) |
355 (let ((trans (assq (car attribute) | 355 (let ((trans (assq (car attribute) |
356 (symbol-value eudc-protocol-attributes-translation-alist)))) | 356 (symbol-value eudc-protocol-attributes-translation-alist)))) |
357 (if trans | 357 (if trans |
358 (cons (cdr trans) (cdr attribute)) | 358 (cons (cdr trans) (cdr attribute)) |
359 attribute))) | 359 attribute))) |
360 query) | 360 query) |
361 query)) | 361 query)) |
362 | 362 |
363 (defun eudc-translate-attribute-list (list) | 363 (defun eudc-translate-attribute-list (list) |
364 "Translate a list of attribute names LIST. | 364 "Translate a list of attribute names LIST. |
365 The translation is done according to | 365 The translation is done according to |
366 `eudc-protocol-attributes-translation-alist'." | 366 `eudc-protocol-attributes-translation-alist'." |
378 (defun eudc-select (choices) | 378 (defun eudc-select (choices) |
379 "Choose one from CHOICES using a completion buffer." | 379 "Choose one from CHOICES using a completion buffer." |
380 (setq eudc-pre-select-window-configuration (current-window-configuration)) | 380 (setq eudc-pre-select-window-configuration (current-window-configuration)) |
381 (setq eudc-insertion-marker (point-marker)) | 381 (setq eudc-insertion-marker (point-marker)) |
382 (with-output-to-temp-buffer "*EUDC Completions*" | 382 (with-output-to-temp-buffer "*EUDC Completions*" |
383 (apply 'display-completion-list | 383 (apply 'display-completion-list |
384 choices | 384 choices |
385 (if eudc-xemacs-p | 385 (if eudc-xemacs-p |
386 '(:activate-callback eudc-insert-selected))))) | 386 '(:activate-callback eudc-insert-selected))))) |
387 | 387 |
388 (defun eudc-insert-selected (event extent user) | 388 (defun eudc-insert-selected (event extent user) |
389 "Insert a completion at the appropriate point." | 389 "Insert a completion at the appropriate point." |
398 | 398 |
399 (defun eudc-query (query &optional return-attributes no-translation) | 399 (defun eudc-query (query &optional return-attributes no-translation) |
400 "Query the current directory server with QUERY. | 400 "Query the current directory server with QUERY. |
401 QUERY is a list of cons cells (ATTR . VALUE) where ATTR is an attribute | 401 QUERY is a list of cons cells (ATTR . VALUE) where ATTR is an attribute |
402 name and VALUE the corresponding value. | 402 name and VALUE the corresponding value. |
403 If NO-TRANSLATION is non-nil, ATTR is translated according to | 403 If NO-TRANSLATION is non-nil, ATTR is translated according to |
404 `eudc-protocol-attributes-translation-alist'. | 404 `eudc-protocol-attributes-translation-alist'. |
405 RETURN-ATTRIBUTES is a list of attributes to return defaulting to | 405 RETURN-ATTRIBUTES is a list of attributes to return defaulting to |
406 `eudc-default-return-attributes'." | 406 `eudc-default-return-attributes'." |
407 (unless eudc-query-function | 407 (unless eudc-query-function |
408 (error "Don't know how to perform the query")) | 408 (error "Don't know how to perform the query")) |
409 (if no-translation | 409 (if no-translation |
410 (funcall eudc-query-function query (or return-attributes | 410 (funcall eudc-query-function query (or return-attributes |
411 eudc-default-return-attributes)) | 411 eudc-default-return-attributes)) |
412 | 412 |
413 (funcall eudc-query-function | 413 (funcall eudc-query-function |
414 (eudc-translate-query query) | 414 (eudc-translate-query query) |
415 (cond | 415 (cond |
416 (return-attributes | 416 (return-attributes |
417 (eudc-translate-attribute-list return-attributes)) | 417 (eudc-translate-attribute-list return-attributes)) |
418 ((listp eudc-default-return-attributes) | 418 ((listp eudc-default-return-attributes) |
419 (eudc-translate-attribute-list eudc-default-return-attributes)) | 419 (eudc-translate-attribute-list eudc-default-return-attributes)) |
420 (t | 420 (t |
421 eudc-default-return-attributes))))) | 421 eudc-default-return-attributes))))) |
422 | 422 |
423 (defun eudc-format-attribute-name-for-display (attribute) | 423 (defun eudc-format-attribute-name-for-display (attribute) |
424 "Format a directory attribute name for display. | 424 "Format a directory attribute name for display. |
425 ATTRIBUTE is looked up in `eudc-user-attribute-names-alist' and replaced | 425 ATTRIBUTE is looked up in `eudc-user-attribute-names-alist' and replaced |
426 by the corresponding user name if any. Otherwise it is capitalized and | 426 by the corresponding user name if any. Otherwise it is capitalized and |
427 underscore characters are replaced by spaces." | 427 underscore characters are replaced by spaces." |
428 (let ((match (assq attribute eudc-user-attribute-names-alist))) | 428 (let ((match (assq attribute eudc-user-attribute-names-alist))) |
429 (if match | 429 (if match |
430 (cdr match) | 430 (cdr match) |
431 (capitalize | 431 (capitalize |
432 (mapconcat 'identity | 432 (mapconcat 'identity |
433 (split-string (symbol-name attribute) "_") | 433 (split-string (symbol-name attribute) "_") |
434 " "))))) | 434 " "))))) |
435 | 435 |
436 (defun eudc-print-attribute-value (field) | 436 (defun eudc-print-attribute-value (field) |
437 "Insert the value of the directory FIELD at point. | 437 "Insert the value of the directory FIELD at point. |
438 The directory attribute name in car of FIELD is looked up in | 438 The directory attribute name in car of FIELD is looked up in |
439 `eudc-attribute-display-method-alist' and the corresponding method, | 439 `eudc-attribute-display-method-alist' and the corresponding method, |
440 if any, is called to print the value in cdr of FIELD." | 440 if any, is called to print the value in cdr of FIELD." |
441 (let ((match (assoc (downcase (car field)) | 441 (let ((match (assoc (downcase (car field)) |
442 eudc-attribute-display-method-alist)) | 442 eudc-attribute-display-method-alist)) |
443 (col (current-column)) | 443 (col (current-column)) |
444 (val (cdr field))) | 444 (val (cdr field))) |
458 (t (list val))))))) | 458 (t (list val))))))) |
459 | 459 |
460 (defun eudc-print-record-field (field column-width) | 460 (defun eudc-print-record-field (field column-width) |
461 "Print the record field FIELD. | 461 "Print the record field FIELD. |
462 FIELD is a list (ATTR VALUE1 VALUE2 ...) or cons-cell (ATTR . VAL) | 462 FIELD is a list (ATTR VALUE1 VALUE2 ...) or cons-cell (ATTR . VAL) |
463 COLUMN-WIDTH is the width of the first display column containing the | 463 COLUMN-WIDTH is the width of the first display column containing the |
464 attribute name ATTR." | 464 attribute name ATTR." |
465 (let ((field-beg (point))) | 465 (let ((field-beg (point))) |
466 ;; The record field that is passed to this function has already been processed | 466 ;; The record field that is passed to this function has already been processed |
467 ;; by `eudc-format-attribute-name-for-display' so we don't need to call it | 467 ;; by `eudc-format-attribute-name-for-display' so we don't need to call it |
468 ;; again to display the attribute name | 468 ;; again to display the attribute name |
469 (insert (format (concat "%" (int-to-string column-width) "s: ") | 469 (insert (format (concat "%" (int-to-string column-width) "s: ") |
470 (car field))) | 470 (car field))) |
471 (put-text-property field-beg (point) 'face 'bold) | 471 (put-text-property field-beg (point) 'face 'bold) |
472 (indent-to (+ 2 column-width)) | 472 (indent-to (+ 2 column-width)) |
473 (eudc-print-attribute-value field))) | 473 (eudc-print-attribute-value field))) |
474 | 474 |
475 (defun eudc-display-records (records &optional raw-attr-names) | 475 (defun eudc-display-records (records &optional raw-attr-names) |
476 "Display the record list RECORDS in a formatted buffer. | 476 "Display the record list RECORDS in a formatted buffer. |
477 If RAW-ATTR-NAMES is non-nil, the raw attribute names are displayed | 477 If RAW-ATTR-NAMES is non-nil, the raw attribute names are displayed |
478 otherwise they are formatted according to `eudc-user-attribute-names-alist'." | 478 otherwise they are formatted according to `eudc-user-attribute-names-alist'." |
479 (let ((buffer (get-buffer-create "*Directory Query Results*")) | 479 (let ((buffer (get-buffer-create "*Directory Query Results*")) |
480 inhibit-read-only | 480 inhibit-read-only |
481 precords | 481 precords |
482 (width 0) | 482 (width 0) |
483 beg | 483 beg |
484 first-record | 484 first-record |
485 attribute-name) | 485 attribute-name) |
486 (switch-to-buffer buffer) | 486 (switch-to-buffer buffer) |
487 (setq buffer-read-only t) | 487 (setq buffer-read-only t) |
488 (setq inhibit-read-only t) | 488 (setq inhibit-read-only t) |
489 (erase-buffer) | 489 (erase-buffer) |
490 (insert "Directory Query Result\n") | 490 (insert "Directory Query Result\n") |
491 (insert "======================\n\n\n") | 491 (insert "======================\n\n\n") |
494 (if eudc-strict-return-matches | 494 (if eudc-strict-return-matches |
495 "Try setting `eudc-strict-return-matches' to nil or change `eudc-default-return-attributes'.\n" | 495 "Try setting `eudc-strict-return-matches' to nil or change `eudc-default-return-attributes'.\n" |
496 "")) | 496 "")) |
497 ;; Replace field names with user names, compute max width | 497 ;; Replace field names with user names, compute max width |
498 (setq precords | 498 (setq precords |
499 (mapcar | 499 (mapcar |
500 (function | 500 (function |
501 (lambda (record) | 501 (lambda (record) |
502 (mapcar | 502 (mapcar |
503 (function | 503 (function |
504 (lambda (field) | 504 (lambda (field) |
505 (setq attribute-name | 505 (setq attribute-name |
506 (if raw-attr-names | 506 (if raw-attr-names |
507 (symbol-name (car field)) | 507 (symbol-name (car field)) |
508 (eudc-format-attribute-name-for-display (car field)))) | 508 (eudc-format-attribute-name-for-display (car field)))) |
509 (if (> (length attribute-name) width) | 509 (if (> (length attribute-name) width) |
510 (setq width (length attribute-name))) | 510 (setq width (length attribute-name))) |
511 (cons attribute-name (cdr field)))) | 511 (cons attribute-name (cdr field)))) |
512 record))) | 512 record))) |
513 records)) | 513 records)) |
514 ;; Display the records | 514 ;; Display the records |
515 (setq first-record (point)) | 515 (setq first-record (point)) |
516 (mapcar | 516 (mapcar |
517 (function | 517 (function |
518 (lambda (record) | 518 (lambda (record) |
519 (setq beg (point)) | 519 (setq beg (point)) |
520 ;; Map over the record fields to print the attribute/value pairs | 520 ;; Map over the record fields to print the attribute/value pairs |
521 (mapcar (function | 521 (mapcar (function |
522 (lambda (field) | 522 (lambda (field) |
523 (eudc-print-record-field field width))) | 523 (eudc-print-record-field field width))) |
524 record) | 524 record) |
525 ;; Store the record internal format in some convenient place | 525 ;; Store the record internal format in some convenient place |
526 (overlay-put (make-overlay beg (point)) | 526 (overlay-put (make-overlay beg (point)) |
527 'eudc-record | 527 'eudc-record |
528 (car records)) | 528 (car records)) |
549 (let (query-alist | 549 (let (query-alist |
550 value) | 550 value) |
551 (if (not (and (boundp 'eudc-form-widget-list) | 551 (if (not (and (boundp 'eudc-form-widget-list) |
552 eudc-form-widget-list)) | 552 eudc-form-widget-list)) |
553 (error "Not in a directory query form buffer") | 553 (error "Not in a directory query form buffer") |
554 (mapcar (function | 554 (mapcar (function |
555 (lambda (wid-field) | 555 (lambda (wid-field) |
556 (setq value (widget-value (cdr wid-field))) | 556 (setq value (widget-value (cdr wid-field))) |
557 (if (not (string= value "")) | 557 (if (not (string= value "")) |
558 (setq query-alist (cons (cons (car wid-field) value) | 558 (setq query-alist (cons (cons (car wid-field) value) |
559 query-alist))))) | 559 query-alist))))) |
560 eudc-form-widget-list) | 560 eudc-form-widget-list) |
561 (kill-buffer (current-buffer)) | 561 (kill-buffer (current-buffer)) |
562 (eudc-display-records (eudc-query query-alist) eudc-use-raw-directory-names)))) | 562 (eudc-display-records (eudc-query query-alist) eudc-use-raw-directory-names)))) |
563 | 563 |
564 | |
565 | 564 |
566 (defun eudc-filter-duplicate-attributes (record) | 565 (defun eudc-filter-duplicate-attributes (record) |
567 "Filter RECORD according to `eudc-duplicate-attribute-handling-method'." | 566 "Filter RECORD according to `eudc-duplicate-attribute-handling-method'." |
568 (let ((rec record) | 567 (let ((rec record) |
569 unique | 568 unique |
575 (not (listp (eudc-cdar rec)))) | 574 (not (listp (eudc-cdar rec)))) |
576 (setq rec (cdr rec))) | 575 (setq rec (cdr rec))) |
577 | 576 |
578 (if (null (eudc-cdar rec)) | 577 (if (null (eudc-cdar rec)) |
579 (list record) ; No duplicate attrs in this record | 578 (list record) ; No duplicate attrs in this record |
580 (mapcar (function | 579 (mapcar (function |
581 (lambda (field) | 580 (lambda (field) |
582 (if (listp (cdr field)) | 581 (if (listp (cdr field)) |
583 (setq duplicates (cons field duplicates)) | 582 (setq duplicates (cons field duplicates)) |
584 (setq unique (cons field unique))))) | 583 (setq unique (cons field unique))))) |
585 record) | 584 record) |
586 (setq result (list unique)) | 585 (setq result (list unique)) |
587 ;; Map over the record fields that have multiple values | 586 ;; Map over the record fields that have multiple values |
588 (mapcar | 587 (mapcar |
589 (function | 588 (function |
590 (lambda (field) | 589 (lambda (field) |
591 (let ((method (if (consp eudc-duplicate-attribute-handling-method) | 590 (let ((method (if (consp eudc-duplicate-attribute-handling-method) |
592 (cdr | 591 (cdr |
593 (assq | 592 (assq |
594 (or | 593 (or |
595 (car | 594 (car |
596 (rassq | 595 (rassq |
597 (car field) | 596 (car field) |
598 (symbol-value | 597 (symbol-value |
599 eudc-protocol-attributes-translation-alist))) | 598 eudc-protocol-attributes-translation-alist))) |
600 (car field)) | 599 (car field)) |
601 eudc-duplicate-attribute-handling-method)) | 600 eudc-duplicate-attribute-handling-method)) |
602 eudc-duplicate-attribute-handling-method))) | 601 eudc-duplicate-attribute-handling-method))) |
603 (cond | 602 (cond |
604 ((or (null method) (eq 'list method)) | 603 ((or (null method) (eq 'list method)) |
605 (setq result | 604 (setq result |
606 (eudc-add-field-to-records field result))) | 605 (eudc-add-field-to-records field result))) |
607 ((eq 'first method) | 606 ((eq 'first method) |
608 (setq result | 607 (setq result |
609 (eudc-add-field-to-records (cons (car field) | 608 (eudc-add-field-to-records (cons (car field) |
610 (eudc-cadr field)) | 609 (eudc-cadr field)) |
611 result))) | 610 result))) |
612 ((eq 'concat method) | 611 ((eq 'concat method) |
613 (setq result | 612 (setq result |
614 (eudc-add-field-to-records (cons (car field) | 613 (eudc-add-field-to-records (cons (car field) |
615 (mapconcat | 614 (mapconcat |
616 'identity | 615 'identity |
617 (cdr field) | 616 (cdr field) |
618 "\n")) result))) | 617 "\n")) result))) |
619 ((eq 'duplicate method) | 618 ((eq 'duplicate method) |
620 (setq result | 619 (setq result |
622 duplicates) | 621 duplicates) |
623 result))) | 622 result))) |
624 | 623 |
625 (defun eudc-filter-partial-records (records attrs) | 624 (defun eudc-filter-partial-records (records attrs) |
626 "Eliminate records that do not caontain all ATTRS from RECORDS." | 625 "Eliminate records that do not caontain all ATTRS from RECORDS." |
627 (delq nil | 626 (delq nil |
628 (mapcar | 627 (mapcar |
629 (function | 628 (function |
630 (lambda (rec) | 629 (lambda (rec) |
631 (if (eval (cons 'and | 630 (if (eval (cons 'and |
632 (mapcar | 631 (mapcar |
633 (function | 632 (function |
634 (lambda (attr) | 633 (lambda (attr) |
635 (consp (assq attr rec)))) | 634 (consp (assq attr rec)))) |
636 attrs))) | 635 attrs))) |
637 rec))) | 636 rec))) |
638 records))) | 637 records))) |
639 | 638 |
640 (defun eudc-add-field-to-records (field records) | 639 (defun eudc-add-field-to-records (field records) |
641 "Add FIELD to each individual record in RECORDS and return the resulting list." | 640 "Add FIELD to each individual record in RECORDS and return the resulting list." |
642 (mapcar (function | 641 (mapcar (function |
643 (lambda (r) | 642 (lambda (r) |
644 (cons field r))) | 643 (cons field r))) |
651 (values (cdr field))) | 650 (values (cdr field))) |
652 ;; Uniquify values first | 651 ;; Uniquify values first |
653 (while values | 652 (while values |
654 (setcdr values (delete (car values) (cdr values))) | 653 (setcdr values (delete (car values) (cdr values))) |
655 (setq values (cdr values))) | 654 (setq values (cdr values))) |
656 (mapcar | 655 (mapcar |
657 (function | 656 (function |
658 (lambda (value) | 657 (lambda (value) |
659 (let ((result-list (copy-sequence records))) | 658 (let ((result-list (copy-sequence records))) |
660 (setq result-list (eudc-add-field-to-records | 659 (setq result-list (eudc-add-field-to-records |
661 (cons (car field) value) | 660 (cons (car field) value) |
662 result-list)) | 661 result-list)) |
663 (setq result (append result-list result)) | 662 (setq result (append result-list result)) |
664 ))) | 663 ))) |
665 (cdr field)) | 664 (cdr field)) |
686 (easy-menu-define eudc-emacs-menu eudc-mode-map "" (eudc-menu)) | 685 (easy-menu-define eudc-emacs-menu eudc-mode-map "" (eudc-menu)) |
687 (setq mode-popup-menu (eudc-menu))) | 686 (setq mode-popup-menu (eudc-menu))) |
688 (run-hooks 'eudc-mode-hook) | 687 (run-hooks 'eudc-mode-hook) |
689 ) | 688 ) |
690 | 689 |
691 ;;}}} | 690 ;;}}} |
692 | 691 |
693 ;;{{{ High-level interfaces (interactive functions) | 692 ;;{{{ High-level interfaces (interactive functions) |
694 | 693 |
695 (defun eudc-customize () | 694 (defun eudc-customize () |
696 "Customize the EUDC package." | 695 "Customize the EUDC package." |
698 (customize-group 'eudc)) | 697 (customize-group 'eudc)) |
699 | 698 |
700 ;;;###autoload | 699 ;;;###autoload |
701 (defun eudc-set-server (server protocol &optional no-save) | 700 (defun eudc-set-server (server protocol &optional no-save) |
702 "Set the directory server to SERVER using PROTOCOL. | 701 "Set the directory server to SERVER using PROTOCOL. |
703 Unless NO-SAVE is non-nil, the server is saved as the default | 702 Unless NO-SAVE is non-nil, the server is saved as the default |
704 server for future sessions." | 703 server for future sessions." |
705 (interactive (list | 704 (interactive (list |
706 (read-from-minibuffer "Directory Server: ") | 705 (read-from-minibuffer "Directory Server: ") |
707 (intern (completing-read "Protocol: " | 706 (intern (completing-read "Protocol: " |
708 (mapcar '(lambda (elt) | 707 (mapcar '(lambda (elt) |
709 (cons (symbol-name elt) | 708 (cons (symbol-name elt) |
710 elt)) | 709 elt)) |
711 eudc-known-protocols))))) | 710 eudc-known-protocols))))) |
712 (unless (or (member protocol | 711 (unless (or (member protocol |
729 (interactive "sName: ") | 728 (interactive "sName: ") |
730 (or eudc-server | 729 (or eudc-server |
731 (call-interactively 'eudc-set-server)) | 730 (call-interactively 'eudc-set-server)) |
732 (let ((result (eudc-query (list (cons 'name name)) '(email))) | 731 (let ((result (eudc-query (list (cons 'name name)) '(email))) |
733 email) | 732 email) |
734 (if (null (cdr result)) | 733 (if (null (cdr result)) |
735 (setq email (eudc-cdaar result)) | 734 (setq email (eudc-cdaar result)) |
736 (error "Multiple match. Use the query form")) | 735 (error "Multiple match. Use the query form")) |
737 (if (interactive-p) | 736 (if (interactive-p) |
738 (if email | 737 (if email |
739 (message "%s" email) | 738 (message "%s" email) |
746 (interactive "sName: ") | 745 (interactive "sName: ") |
747 (or eudc-server | 746 (or eudc-server |
748 (call-interactively 'eudc-set-server)) | 747 (call-interactively 'eudc-set-server)) |
749 (let ((result (eudc-query (list (cons 'name name)) '(phone))) | 748 (let ((result (eudc-query (list (cons 'name name)) '(phone))) |
750 phone) | 749 phone) |
751 (if (null (cdr result)) | 750 (if (null (cdr result)) |
752 (setq phone (eudc-cdaar result)) | 751 (setq phone (eudc-cdaar result)) |
753 (error "Multiple match. Use the query form")) | 752 (error "Multiple match. Use the query form")) |
754 (if (interactive-p) | 753 (if (interactive-p) |
755 (if phone | 754 (if phone |
756 (message "%s" phone) | 755 (message "%s" phone) |
762 When called interactively the list is formatted in a dedicated buffer | 761 When called interactively the list is formatted in a dedicated buffer |
763 otherwise a list of symbols is returned." | 762 otherwise a list of symbols is returned." |
764 (interactive) | 763 (interactive) |
765 (if eudc-list-attributes-function | 764 (if eudc-list-attributes-function |
766 (let ((entries (funcall eudc-list-attributes-function (interactive-p)))) | 765 (let ((entries (funcall eudc-list-attributes-function (interactive-p)))) |
767 (if entries | 766 (if entries |
768 (if (interactive-p) | 767 (if (interactive-p) |
769 (eudc-display-records entries t) | 768 (eudc-display-records entries t) |
770 entries))) | 769 entries))) |
771 (error "The %s protocol has no support for listing attributes" eudc-protocol))) | 770 (error "The %s protocol has no support for listing attributes" eudc-protocol))) |
772 | 771 |
776 query-alist | 775 query-alist |
777 key val cell) | 776 key val cell) |
778 (if format | 777 (if format |
779 (progn | 778 (progn |
780 (while (and words format) | 779 (while (and words format) |
781 (setq query-alist (cons (cons (car format) (car words)) | 780 (setq query-alist (cons (cons (car format) (car words)) |
782 query-alist)) | 781 query-alist)) |
783 (setq words (cdr words) | 782 (setq words (cdr words) |
784 format (cdr format))) | 783 format (cdr format))) |
785 ;; If the same attribute appears more than once, merge | 784 ;; If the same attribute appears more than once, merge |
786 ;; the corresponding values | 785 ;; the corresponding values |
812 format | 811 format |
813 nil)) | 812 nil)) |
814 format-list))) | 813 format-list))) |
815 (setq n (1- n))) | 814 (setq n (1- n))) |
816 formats)) | 815 formats)) |
817 | |
818 | 816 |
819 | 817 |
820 ;;;###autoload | 818 ;;;###autoload |
821 (defun eudc-expand-inline (&optional replace) | 819 (defun eudc-expand-inline (&optional replace) |
822 "Query the directory server, and expand the query string before point. | 820 "Query the directory server, and expand the query string before point. |
823 The query string consists of the buffer substring from the point back to | 821 The query string consists of the buffer substring from the point back to |
824 the preceding comma, colon or beginning of line. | 822 the preceding comma, colon or beginning of line. |
825 The variable `eudc-inline-query-format' controls how to associate the | 823 The variable `eudc-inline-query-format' controls how to associate the |
826 individual inline query words with directory attribute names. | 824 individual inline query words with directory attribute names. |
827 After querying the server for the given string, the expansion specified by | 825 After querying the server for the given string, the expansion specified by |
828 `eudc-inline-expansion-format' is inserted in the buffer at point. | 826 `eudc-inline-expansion-format' is inserted in the buffer at point. |
829 If REPLACE is non nil, then this expansion replaces the name in the buffer. | 827 If REPLACE is non nil, then this expansion replaces the name in the buffer. |
830 `eudc-expansion-overwrites-query' being non nil inverts the meaning of REPLACE. | 828 `eudc-expansion-overwrites-query' being non nil inverts the meaning of REPLACE. |
831 Multiple servers can be tried with the same query until one finds a match, | 829 Multiple servers can be tried with the same query until one finds a match, |
832 see `eudc-inline-expansion-servers'" | 830 see `eudc-inline-expansion-servers'" |
833 (interactive) | 831 (interactive) |
834 (if (memq eudc-inline-expansion-servers | 832 (if (memq eudc-inline-expansion-servers |
835 '(current-server server-then-hotlist)) | 833 '(current-server server-then-hotlist)) |
836 (or eudc-server | 834 (or eudc-server |
837 (call-interactively 'eudc-set-server)) | 835 (call-interactively 'eudc-set-server)) |
838 (or eudc-server-hotlist | 836 (or eudc-server-hotlist |
839 (error "No server in the hotlist"))) | 837 (error "No server in the hotlist"))) |
840 (let* ((end (point)) | 838 (let* ((end (point)) |
841 (beg (save-excursion | 839 (beg (save-excursion |
842 (if (re-search-backward "\\([:,]\\|^\\)[ \t]*" | 840 (if (re-search-backward "\\([:,]\\|^\\)[ \t]*" |
843 (save-excursion | 841 (save-excursion |
844 (beginning-of-line) | 842 (beginning-of-line) |
845 (point)) | 843 (point)) |
846 'move) | 844 'move) |
847 (goto-char (match-end 0))) | 845 (goto-char (match-end 0))) |
856 servers) | 854 servers) |
857 | 855 |
858 ;; Prepare the list of servers to query | 856 ;; Prepare the list of servers to query |
859 (setq servers (copy-sequence eudc-server-hotlist)) | 857 (setq servers (copy-sequence eudc-server-hotlist)) |
860 (setq servers | 858 (setq servers |
861 (cond | 859 (cond |
862 ((eq eudc-inline-expansion-servers 'hotlist) | 860 ((eq eudc-inline-expansion-servers 'hotlist) |
863 eudc-server-hotlist) | 861 eudc-server-hotlist) |
864 ((eq eudc-inline-expansion-servers 'server-then-hotlist) | 862 ((eq eudc-inline-expansion-servers 'server-then-hotlist) |
865 (cons (cons eudc-server eudc-protocol) | 863 (cons (cons eudc-server eudc-protocol) |
866 (delete (cons eudc-server eudc-protocol) servers))) | 864 (delete (cons eudc-server eudc-protocol) servers))) |
873 (> (length servers) eudc-max-servers-to-query)) | 871 (> (length servers) eudc-max-servers-to-query)) |
874 (setcdr (nthcdr (1- eudc-max-servers-to-query) servers) nil)) | 872 (setcdr (nthcdr (1- eudc-max-servers-to-query) servers) nil)) |
875 | 873 |
876 (condition-case signal | 874 (condition-case signal |
877 (progn | 875 (progn |
878 (setq response | 876 (setq response |
879 (catch 'found | 877 (catch 'found |
880 ;; Loop on the servers | 878 ;; Loop on the servers |
881 (while servers | 879 (while servers |
882 (eudc-set-server (eudc-caar servers) (eudc-cdar servers) t) | 880 (eudc-set-server (eudc-caar servers) (eudc-cdar servers) t) |
883 | 881 |
884 ;; Determine which formats apply in the query-format list | 882 ;; Determine which formats apply in the query-format list |
885 (setq query-formats | 883 (setq query-formats |
886 (or | 884 (or |
887 (eudc-extract-n-word-formats eudc-inline-query-format | 885 (eudc-extract-n-word-formats eudc-inline-query-format |
888 (length query-words)) | 886 (length query-words)) |
889 (if (null eudc-protocol-has-default-query-attributes) | 887 (if (null eudc-protocol-has-default-query-attributes) |
890 '(name)))) | 888 '(name)))) |
891 | 889 |
892 ;; Loop on query-formats | 890 ;; Loop on query-formats |
893 (while query-formats | 891 (while query-formats |
894 (setq response | 892 (setq response |
895 (eudc-query | 893 (eudc-query |
896 (eudc-format-query query-words (car query-formats)) | 894 (eudc-format-query query-words (car query-formats)) |
904 nil)) | 902 nil)) |
905 | 903 |
906 | 904 |
907 (if (null response) | 905 (if (null response) |
908 (error "No match") | 906 (error "No match") |
909 | 907 |
910 ;; Process response through eudc-inline-expansion-format | 908 ;; Process response through eudc-inline-expansion-format |
911 (while response | 909 (while response |
912 (setq response-string (apply 'format | 910 (setq response-string (apply 'format |
913 (car eudc-inline-expansion-format) | 911 (car eudc-inline-expansion-format) |
914 (mapcar (function | 912 (mapcar (function |
915 (lambda (field) | 913 (lambda (field) |
916 (or (cdr (assq field (car response))) | 914 (or (cdr (assq field (car response))) |
917 ""))) | 915 ""))) |
918 (eudc-translate-attribute-list | 916 (eudc-translate-attribute-list |
919 (cdr eudc-inline-expansion-format))))) | 917 (cdr eudc-inline-expansion-format))))) |
920 (if (> (length response-string) 0) | 918 (if (> (length response-string) 0) |
921 (setq response-strings | 919 (setq response-strings |
922 (cons response-string response-strings))) | 920 (cons response-string response-strings))) |
923 (setq response (cdr response))) | 921 (setq response (cdr response))) |
924 | 922 |
925 (if (or | 923 (if (or |
926 (and replace (not eudc-expansion-overwrites-query)) | 924 (and replace (not eudc-expansion-overwrites-query)) |
927 (and (not replace) eudc-expansion-overwrites-query)) | 925 (and (not replace) eudc-expansion-overwrites-query)) |
928 (delete-region beg end)) | 926 (delete-region beg end)) |
929 (cond | 927 (cond |
930 ((or (= (length response-strings) 1) | 928 ((or (= (length response-strings) 1) |
931 (null eudc-multiple-match-handling-method) | 929 (null eudc-multiple-match-handling-method) |
932 (eq eudc-multiple-match-handling-method 'first)) | 930 (eq eudc-multiple-match-handling-method 'first)) |
933 (insert (car response-strings))) | 931 (insert (car response-strings))) |
934 ((eq eudc-multiple-match-handling-method 'select) | 932 ((eq eudc-multiple-match-handling-method 'select) |
944 (t | 942 (t |
945 (or (and (equal eudc-server eudc-former-server) | 943 (or (and (equal eudc-server eudc-former-server) |
946 (equal eudc-protocol eudc-former-protocol)) | 944 (equal eudc-protocol eudc-former-protocol)) |
947 (eudc-set-server eudc-former-server eudc-former-protocol t)) | 945 (eudc-set-server eudc-former-server eudc-former-protocol t)) |
948 (signal (car signal) (cdr signal)))))) | 946 (signal (car signal) (cdr signal)))))) |
949 | 947 |
950 ;;;###autoload | 948 ;;;###autoload |
951 (defun eudc-query-form (&optional get-fields-from-server) | 949 (defun eudc-query-form (&optional get-fields-from-server) |
952 "Display a form to query the directory server. | 950 "Display a form to query the directory server. |
953 If given a non-nil argument GET-FIELDS-FROM-SERVER, the function first | 951 If given a non-nil argument GET-FIELDS-FROM-SERVER, the function first |
954 queries the server for the existing fields and displays a corresponding form." | 952 queries the server for the existing fields and displays a corresponding form." |
968 (kill-all-local-variables) | 966 (kill-all-local-variables) |
969 (make-local-variable 'eudc-form-widget-list) | 967 (make-local-variable 'eudc-form-widget-list) |
970 (widget-insert "Directory Query Form\n") | 968 (widget-insert "Directory Query Form\n") |
971 (widget-insert "====================\n\n") | 969 (widget-insert "====================\n\n") |
972 (widget-insert "Current server is: " (or eudc-server | 970 (widget-insert "Current server is: " (or eudc-server |
973 (progn | 971 (progn |
974 (call-interactively 'eudc-set-server) | 972 (call-interactively 'eudc-set-server) |
975 eudc-server)) | 973 eudc-server)) |
976 "\n") | 974 "\n") |
977 (widget-insert "Protocol : " (symbol-name eudc-protocol) "\n") | 975 (widget-insert "Protocol : " (symbol-name eudc-protocol) "\n") |
978 ;; Build the list of prompts | 976 ;; Build the list of prompts |
988 (mapcar (function | 986 (mapcar (function |
989 (lambda (prompt) | 987 (lambda (prompt) |
990 (if (> (length prompt) width) | 988 (if (> (length prompt) width) |
991 (setq width (length prompt))))) | 989 (setq width (length prompt))))) |
992 prompts) | 990 prompts) |
993 ;; Insert the first widget out of the mapcar to leave the cursor | 991 ;; Insert the first widget out of the mapcar to leave the cursor |
994 ;; in the first field | 992 ;; in the first field |
995 (widget-insert "\n\n" (format (concat "%" (int-to-string width) "s: ") (car prompts))) | 993 (widget-insert "\n\n" (format (concat "%" (int-to-string width) "s: ") (car prompts))) |
996 (setq pt (point)) | 994 (setq pt (point)) |
997 (setq widget (widget-create 'editable-field :size 15)) | 995 (setq widget (widget-create 'editable-field :size 15)) |
998 (setq eudc-form-widget-list (cons (cons (car fields) widget) | 996 (setq eudc-form-widget-list (cons (cons (car fields) widget) |
999 eudc-form-widget-list)) | 997 eudc-form-widget-list)) |
1116 (if (> pt (point-min)) | 1114 (if (> pt (point-min)) |
1117 (goto-char pt) | 1115 (goto-char pt) |
1118 (error "No more records before point"))))) | 1116 (error "No more records before point"))))) |
1119 | 1117 |
1120 | 1118 |
1121 | |
1122 ;;}}} | 1119 ;;}}} |
1123 | 1120 |
1124 ;;{{{ Menus an keymaps | 1121 ;;{{{ Menus an keymaps |
1125 | 1122 |
1126 (require 'easymenu) | 1123 (require 'easymenu) |
1127 | 1124 |
1128 (setq eudc-mode-map | 1125 (setq eudc-mode-map |
1129 (let ((map (make-sparse-keymap))) | 1126 (let ((map (make-sparse-keymap))) |
1130 (define-key map "q" 'kill-this-buffer) | 1127 (define-key map "q" 'kill-this-buffer) |
1131 (define-key map "x" 'kill-this-buffer) | 1128 (define-key map "x" 'kill-this-buffer) |
1132 (define-key map "f" 'eudc-query-form) | 1129 (define-key map "f" 'eudc-query-form) |
1133 (define-key map "b" 'eudc-try-bbdb-insert) | 1130 (define-key map "b" 'eudc-try-bbdb-insert) |
1136 map)) | 1133 map)) |
1137 (set-keymap-parent eudc-mode-map widget-keymap) | 1134 (set-keymap-parent eudc-mode-map widget-keymap) |
1138 | 1135 |
1139 (defconst eudc-custom-generated-menu (cdr (custom-menu-create 'eudc))) | 1136 (defconst eudc-custom-generated-menu (cdr (custom-menu-create 'eudc))) |
1140 | 1137 |
1141 (defconst eudc-tail-menu | 1138 (defconst eudc-tail-menu |
1142 `(["---" nil nil] | 1139 `(["---" nil nil] |
1143 ["Query with Form" eudc-query-form t] | 1140 ["Query with Form" eudc-query-form t] |
1144 ["Expand Inline Query" eudc-expand-inline t] | 1141 ["Expand Inline Query" eudc-expand-inline t] |
1145 ["Insert Record into BBDB" eudc-insert-record-at-point-into-bbdb | 1142 ["Insert Record into BBDB" eudc-insert-record-at-point-into-bbdb |
1146 (and (or (featurep 'bbdb) | 1143 (and (or (featurep 'bbdb) |
1147 (prog1 (locate-library "bbdb") (message ""))) | 1144 (prog1 (locate-library "bbdb") (message ""))) |
1148 (overlays-at (point)) | 1145 (overlays-at (point)) |
1149 (overlay-get (car (overlays-at (point))) 'eudc-record))] | 1146 (overlay-get (car (overlays-at (point))) 'eudc-record))] |
1150 ["Insert All Records into BBDB" eudc-batch-export-records-to-bbdb | 1147 ["Insert All Records into BBDB" eudc-batch-export-records-to-bbdb |
1151 (and (eq major-mode 'eudc-mode) | 1148 (and (eq major-mode 'eudc-mode) |
1152 (or (featurep 'bbdb) | 1149 (or (featurep 'bbdb) |
1153 (prog1 (locate-library "bbdb") (message ""))))] | 1150 (prog1 (locate-library "bbdb") (message ""))))] |
1154 ["---" nil nil] | 1151 ["---" nil nil] |
1155 ["Get Email" eudc-get-email t] | 1152 ["Get Email" eudc-get-email t] |
1156 ["Get Phone" eudc-get-phone t] | 1153 ["Get Phone" eudc-get-phone t] |
1157 ["List Valid Attribute Names" eudc-get-attribute-list t] | 1154 ["List Valid Attribute Names" eudc-get-attribute-list t] |
1158 ["---" nil nil] | 1155 ["---" nil nil] |
1159 ,(cons "Customize" eudc-custom-generated-menu))) | 1156 ,(cons "Customize" eudc-custom-generated-menu))) |
1160 | 1157 |
1161 | 1158 |
1162 (defconst eudc-server-menu | 1159 (defconst eudc-server-menu |
1163 '(["---" nil nil] | 1160 '(["---" nil nil] |
1164 ["Bookmark Current Server" eudc-bookmark-current-server t] | 1161 ["Bookmark Current Server" eudc-bookmark-current-server t] |
1165 ["Edit Server List" eudc-edit-hotlist t] | 1162 ["Edit Server List" eudc-edit-hotlist t] |
1166 ["New Server" eudc-set-server t])) | 1163 ["New Server" eudc-set-server t])) |
1167 | 1164 |
1168 (defun eudc-menu () | 1165 (defun eudc-menu () |
1169 (let (command) | 1166 (let (command) |
1170 (append '("Directory Search") | 1167 (append '("Directory Search") |
1171 (list | 1168 (list |
1172 (append | 1169 (append |
1173 '("Server") | 1170 '("Server") |
1174 (mapcar | 1171 (mapcar |
1175 (function | 1172 (function |
1176 (lambda (servspec) | 1173 (lambda (servspec) |
1177 (let* ((server (car servspec)) | 1174 (let* ((server (car servspec)) |
1178 (protocol (cdr servspec)) | 1175 (protocol (cdr servspec)) |
1179 (proto-name (symbol-name protocol))) | 1176 (proto-name (symbol-name protocol))) |
1180 (setq command (intern (concat "eudc-set-server-" | 1177 (setq command (intern (concat "eudc-set-server-" |
1181 server | 1178 server |
1182 "-" | 1179 "-" |
1183 proto-name))) | 1180 proto-name))) |
1184 (if (not (fboundp command)) | 1181 (if (not (fboundp command)) |
1185 (fset command | 1182 (fset command |
1186 `(lambda () | 1183 `(lambda () |
1187 (interactive) | 1184 (interactive) |
1188 (eudc-set-server ,server (quote ,protocol)) | 1185 (eudc-set-server ,server (quote ,protocol)) |
1189 (message "Selected directory server is now %s (%s)" | 1186 (message "Selected directory server is now %s (%s)" |
1190 ,server | 1187 ,server |
1191 ,proto-name)))) | 1188 ,proto-name)))) |
1192 (vector (format "%s (%s)" server proto-name) | 1189 (vector (format "%s (%s)" server proto-name) |
1193 command | 1190 command |
1194 :style 'radio | 1191 :style 'radio |
1195 :selected `(equal eudc-server ,server))))) | 1192 :selected `(equal eudc-server ,server))))) |
1196 eudc-server-hotlist) | 1193 eudc-server-hotlist) |
1197 eudc-server-menu)) | 1194 eudc-server-menu)) |
1198 eudc-tail-menu))) | 1195 eudc-tail-menu))) |
1199 | 1196 |
1200 (defun eudc-install-menu () | 1197 (defun eudc-install-menu () |
1201 (cond | 1198 (cond |
1202 ((and eudc-xemacs-p (featurep 'menubar)) | 1199 ((and eudc-xemacs-p (featurep 'menubar)) |
1203 (add-submenu '("Tools") (eudc-menu))) | 1200 (add-submenu '("Tools") (eudc-menu))) |
1204 (eudc-emacs-p | 1201 (eudc-emacs-p |
1205 (cond | 1202 (cond |
1206 ((fboundp 'easy-menu-add-item) | 1203 ((fboundp 'easy-menu-add-item) |
1207 (let ((menu (eudc-menu))) | 1204 (let ((menu (eudc-menu))) |
1208 (easy-menu-add-item nil '("tools") (easy-menu-create-menu (car menu) | 1205 (easy-menu-add-item nil '("tools") (easy-menu-create-menu (car menu) |
1209 (cdr menu))))) | 1206 (cdr menu))))) |
1210 ((fboundp 'easy-menu-create-keymaps) | 1207 ((fboundp 'easy-menu-create-keymaps) |
1211 (easy-menu-define eudc-menu-map eudc-mode-map "Directory Client Menu" (eudc-menu)) | 1208 (easy-menu-define eudc-menu-map eudc-mode-map "Directory Client Menu" (eudc-menu)) |
1212 (define-key | 1209 (define-key |
1213 global-map | 1210 global-map |
1214 [menu-bar tools eudc] | 1211 [menu-bar tools eudc] |
1215 (cons "Directory Search" | 1212 (cons "Directory Search" |
1216 (easy-menu-create-keymaps "Directory Search" (cdr (eudc-menu)))))) | 1213 (easy-menu-create-keymaps "Directory Search" (cdr (eudc-menu)))))) |
1217 (t | 1214 (t |
1218 (error "Unknown version of easymenu")))) | 1215 (error "Unknown version of easymenu")))) |
1219 )) | 1216 )) |
1225 (if (and (not noninteractive) | 1222 (if (and (not noninteractive) |
1226 (and (locate-library eudc-options-file) | 1223 (and (locate-library eudc-options-file) |
1227 (message "")) ; Remove modeline message | 1224 (message "")) ; Remove modeline message |
1228 (not (featurep 'eudc-options-file))) | 1225 (not (featurep 'eudc-options-file))) |
1229 (load eudc-options-file)) | 1226 (load eudc-options-file)) |
1230 | 1227 |
1231 | |
1232 ;;; Install the full menu | 1228 ;;; Install the full menu |
1233 (unless (featurep 'infodock) | 1229 (unless (featurep 'infodock) |
1234 (eudc-install-menu)) | 1230 (eudc-install-menu)) |
1235 | 1231 |
1236 | 1232 |
1241 "Load the Emacs Unified Directory Client. | 1237 "Load the Emacs Unified Directory Client. |
1242 This does nothing except loading eudc by autoload side-effect." | 1238 This does nothing except loading eudc by autoload side-effect." |
1243 (interactive) | 1239 (interactive) |
1244 nil) | 1240 nil) |
1245 | 1241 |
1246 ;;}}} | |
1247 | |
1248 ;;;###autoload | 1242 ;;;###autoload |
1249 (cond ((not (string-match "XEmacs" emacs-version)) | 1243 (cond ((not eudc-xemacs-p) |
1250 (defvar eudc-tools-menu (make-sparse-keymap "Directory Search")) | 1244 (defvar eudc-tools-menu (make-sparse-keymap "Directory Search")) |
1251 (fset 'eudc-tools-menu (symbol-value 'eudc-tools-menu)) | 1245 (fset 'eudc-tools-menu (symbol-value 'eudc-tools-menu)) |
1252 | |
1253 (define-key eudc-tools-menu [phone] | 1246 (define-key eudc-tools-menu [phone] |
1254 '("Get Phone" . eudc-get-phone)) | 1247 '("Get Phone" . eudc-get-phone)) |
1255 (define-key eudc-tools-menu [email] | 1248 (define-key eudc-tools-menu [email] |
1256 '("Get Email" . eudc-get-email)) | 1249 '("Get Email" . eudc-get-email)) |
1257 (define-key eudc-tools-menu [separator-eudc-email] | 1250 (define-key eudc-tools-menu [separator-eudc-email] |
1264 '("--")) | 1257 '("--")) |
1265 (define-key eudc-tools-menu [new] | 1258 (define-key eudc-tools-menu [new] |
1266 '("New Server" . eudc-set-server)) | 1259 '("New Server" . eudc-set-server)) |
1267 (define-key eudc-tools-menu [load] | 1260 (define-key eudc-tools-menu [load] |
1268 '("Load Hotlist of Servers" . eudc-load-eudc))) | 1261 '("Load Hotlist of Servers" . eudc-load-eudc))) |
1269 | 1262 |
1270 (t | 1263 (t |
1271 (let ((menu '("Directory Search" | 1264 (let ((menu '("Directory Search" |
1272 ["Load Hotlist of Servers" eudc-load-eudc t] | 1265 ["Load Hotlist of Servers" eudc-load-eudc t] |
1273 ["New Server" eudc-set-server t] | 1266 ["New Server" eudc-set-server t] |
1274 ["---" nil nil] | 1267 ["---" nil nil] |
1276 ["Expand Inline Query" eudc-expand-inline t] | 1269 ["Expand Inline Query" eudc-expand-inline t] |
1277 ["---" nil nil] | 1270 ["---" nil nil] |
1278 ["Get Email" eudc-get-email t] | 1271 ["Get Email" eudc-get-email t] |
1279 ["Get Phone" eudc-get-phone t]))) | 1272 ["Get Phone" eudc-get-phone t]))) |
1280 (if (not (featurep 'eudc-autoloads)) | 1273 (if (not (featurep 'eudc-autoloads)) |
1281 (if (string-match "XEmacs" emacs-version) | 1274 (if eudc-xemacs-p |
1282 (if (and (featurep 'menubar) | 1275 (if (and (featurep 'menubar) |
1283 (not (featurep 'infodock))) | 1276 (not (featurep 'infodock))) |
1284 (add-submenu '("Tools") menu)) | 1277 (add-submenu '("Tools") menu)) |
1285 (require 'easymenu) | 1278 (require 'easymenu) |
1286 (cond | 1279 (cond |
1287 ((fboundp 'easy-menu-add-item) | 1280 ((fboundp 'easy-menu-add-item) |
1288 (easy-menu-add-item nil '("tools") | 1281 (easy-menu-add-item nil '("tools") |
1289 (easy-menu-create-menu (car menu) | 1282 (easy-menu-create-menu (car menu) |
1290 (cdr menu)))) | 1283 (cdr menu)))) |
1291 ((fboundp 'easy-menu-create-keymaps) | 1284 ((fboundp 'easy-menu-create-keymaps) |
1292 (define-key | 1285 (define-key |
1293 global-map | 1286 global-map |
1294 [menu-bar tools eudc] | 1287 [menu-bar tools eudc] |
1295 (cons "Directory Search" | 1288 (cons "Directory Search" |
1296 (easy-menu-create-keymaps "Directory Search" | 1289 (easy-menu-create-keymaps "Directory Search" |
1297 (cdr menu))))))))))) | 1290 (cdr menu))))))))))) |
1298 | 1291 |
1299 ;;}}} | 1292 ;;}}} |
1300 | 1293 |
1301 (provide 'eudc) | 1294 (provide 'eudc) |
1302 | 1295 |
1303 ;;; eudc.el ends here | 1296 ;;; eudc.el ends here |