← Back to branch summary

~ubuntu-branches/ubuntu/utopic/bbdb/utopic

« back to all changes in this revision

Viewing changes to .pc/debian-changes/bits/bbdb-ldif.el

  • Committer: Package Import Robot
  • Author(s): Barak A. Pearlmutter
  • Date: 2014-02-24 12:17:32 UTC
  • mfrom: (13.1.1 sid)
  • Revision ID: package-import@ubuntu.com-20140224121732-y107ua2xbj8xpcau
Tags: 2.36-4
* engage dh autoreconf, rm ./configure, relax regarding ./configure +x bit
* updates to debian/README.Debian and debian/README.source
* remove CVS keyword expansion artifacts
* add savannah repo pointers to bbdb.texinfo
* remove PHONY stuff in debian/rules
* remove stray old-style quasiquote in macro
* allow emacs24 to satisfy dependencies
* bump standards version, dh version
* single debian patch source option

Show diffs side-by-side

added added

removed removed

Lines of Context:
.pc/debian-changes/bits/bbdb-ldif.el
 
1
;;; Copyright (C) 1998,2000 by Niels Elgaard Larsen <elgaard@diku.dk>
 
2
 
 
3
;;; $Log: bbdb-ldif.el,v $
 
4
;;; Revision 1.1  2006/02/04 15:35:15  joerg
 
5
;;; Added
 
6
;;;
 
7
;;; Revision 1.1  2005/02/13 14:16:03  waider
 
8
;;; * added new file, with minor abuse to make it work with current BBDB
 
9
;;;
 
10
;;; Revision 1.7  2000/03/15 14:16:44  elgaard
 
11
;;; Fixed problem with concatenation of strings/integers
 
12
;;; Changed mobiletelephonenumber to cellphone to follow Netscape :-(
 
13
;;; Added support for pagerphone
 
14
;;;
 
15
;;; Revision 1.6  1998/09/08 12:35:27  elgaard
 
16
;;; Works with xemacs, emacs, emacs-19.34, bbdb-2 and bbdb-1.51
 
17
;;; Bugfixes
 
18
;;;
 
19
;; Rev 0.3
 
20
;; Can export mail-alias'es and .mailrc aliases to Netscape Mailing List
 
21
;;Bugfix.
 
22
;;
 
23
 
 
24
;; Rev. 0.2.1
 
25
;; Compiles without MEL
 
26
 
 
27
;; Rev. 0.2
 
28
;; Notes work better now
 
29
;; added 'bbdb-elided-export-ldif'
 
30
;; Fixed base64 bug
 
31
 
 
32
;;     This program is free software; you can redistribute it and/or modify
 
33
;;     it under the terms of the GNU General Public License as published by
 
34
;;     the Free Software Foundation; either version 2 of the License, or
 
35
;;     (at your option) any later version.
 
36
 
 
37
;;     This program is distributed in the hope that it will be useful,
 
38
;;     but WITHOUT ANY WARRANTY; without even the implied warranty of
 
39
;;     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 
40
;;     GNU General Public License for more details.
 
41
 
 
42
;;     You should have received a copy of the GNU General Public License
 
43
;;     along with this program; if not, write to the Free Software
 
44
;;     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 
45
 
 
46
;; Niels Elgaard Larsen, <URL:mailto:elgaard@diku.dk>
 
47
;; July 18, 1998
 
48
 
 
49
;; bbdb-import-ldif imports LDIF entries
 
50
;; bbdb-to-ldif export bbdb to LDIF.
 
51
 
 
52
;; Both functions are somewhat specialized for Netscape Communicator (and Mozilla)
 
53
 
 
54
 
 
55
 
 
56
;;; Installation:
 
57
 
 
58
;;; Put (add-hook 'bbdb-load-hook (function (lambda () (require 'bbdb-ldif))))
 
59
;;; into your .emacs, or autoload it.
 
60
 
 
61
 
 
62
;; If you use non-ASCII characters recode the output file from emacs:
 
63
;;  "recode  ..UTF-8 output.ldif"
 
64
;; and the input file from Netscape:
 
65
;;  "recode  UTF-8.. i2.ldif "
 
66
;;;;;; Does not work for base-64 encoded text.
 
67
 
 
68
(require 'bbdb)
 
69
 
 
70
;; WAIDER MOD FEB 2005
 
71
;; deprecated functions. I should fix the code rather than do this, but.
 
72
(defun bbdb-address-street1(addr)
 
73
  (nth 0 (bbdb-address-streets addr)))
 
74
(defun bbdb-address-street2(addr)
 
75
  (nth 1 (bbdb-address-streets addr)))
 
76
(defun bbdb-address-street3(addr)
 
77
  (nth 2 (bbdb-address-streets addr)))
 
78
 
 
79
(if (locate-library "mel") (require 'mel)
 
80
  (message "We try without MEL (base64 operation), multiline fields will not work"
 
81
       )
 
82
  )
 
83
 
 
84
(if  (fboundp 'split-string) nil
 
85
  (defun split-string (string &optional pattern)
 
86
    "Return a list of substrings of STRING which are separated by PATTERN.
 
87
If PATTERN is omitted, it defaults to \"[ \\f\\t\\n\\r\\v]+\"."
 
88
    (or pattern
 
89
    (setq pattern "[ \f\t\n\r\v]+"))
 
90
    ;; The FSF version of this function takes care not to cons in case
 
91
    ;; of infloop.  Maybe we should synch?
 
92
    (let (parts (start 0))
 
93
      (while (string-match pattern string start)
 
94
    (setq parts (cons (substring string start (match-beginning 0)) parts)
 
95
          start (match-end 0)))
 
96
      (nreverse (cons (substring string start) parts))))
 
97
  )
 
98
 
 
99
(if (fboundp 'caadr) nil (defun caadr (foo) (car (car (cdr foo)))))
 
100
 
 
101
 
 
102
 
 
103
(defvar bbdb-ldif-nsnil "?" "Null name for Netscape")
 
104
 
 
105
(defun tnsnil (st)
 
106
     (if (equal st bbdb-ldif-nsnil)
 
107
     nil
 
108
       st))
 
109
 
 
110
(defvar bbdb-elided-export-ldif nil "Set this to a list of some
 
111
of the symbols '(address phone net notes) to select those fields to be left
 
112
out when exporting to LDIF format"
 
113
)
 
114
 
 
115
;(require 'bbdb-snarf)
 
116
(require 'bbdb-com)
 
117
 
 
118
 
 
119
(defvar bbdb-ldif-prefix "xbbdb")
 
120
(defvar bbdb-ldif-prefixh "xhbbdb")
 
121
 
 
122
;;;; From bbdb-snarf with bugfix:
 
123
(defun bbdb-merge-internally-ldif (old-record new-record)
 
124
  "Merge two records.  NEW-RECORDS wins over OLD in cases of ties."
 
125
  (if (and (null (bbdb-record-firstname new-record))
 
126
       (bbdb-record-firstname old-record))
 
127
      (bbdb-record-set-firstname new-record (bbdb-record-firstname old-record)))
 
128
  (if (and (null (bbdb-record-lastname new-record))
 
129
       (bbdb-record-lastname old-record))
 
130
      (bbdb-record-set-lastname new-record (bbdb-record-lastname old-record)))
 
131
  (if (and (null (bbdb-record-company new-record))
 
132
       (bbdb-record-company old-record))
 
133
      (bbdb-record-set-company new-record (bbdb-record-company old-record)))
 
134
  ;; nets
 
135
  (let ((old-nets (bbdb-record-net old-record))
 
136
    (new-nets (bbdb-record-net new-record)))
 
137
    (while old-nets
 
138
      (if (not (member (car old-nets) new-nets))
 
139
      (setq new-nets (append new-nets (list (car old-nets)))))
 
140
      (setq old-nets (cdr old-nets)))
 
141
    (bbdb-record-set-net new-record new-nets))
 
142
  ;; addrs
 
143
  (let ((old-addresses (bbdb-record-addresses old-record))
 
144
    (new-addresses (bbdb-record-addresses new-record)))
 
145
    (while old-addresses
 
146
      (if (not (member (car old-addresses) new-addresses))
 
147
      (setq new-addresses (append new-addresses (list (car old-addresses)))))
 
148
      (setq old-addresses (cdr old-addresses)))
 
149
    (bbdb-record-set-addresses new-record new-addresses))
 
150
  ;; phones
 
151
  (let ((old-phones (bbdb-record-phones old-record))
 
152
    (new-phones (bbdb-record-phones new-record)))
 
153
    (while old-phones
 
154
      (if (not (member (car old-phones) new-phones))
 
155
      (setq new-phones (append new-phones (list (car old-phones)))))
 
156
      (setq old-phones (cdr old-phones)))
 
157
    (bbdb-record-set-phones new-record new-phones))
 
158
  ;; notes
 
159
  (let ((old-notes (bbdb-ensure-list (bbdb-record-raw-notes old-record)))
 
160
    (new-notes (bbdb-ensure-list (bbdb-record-raw-notes new-record))))
 
161
    (while old-notes
 
162
      (if (not (member (car old-notes) new-notes))
 
163
      (setq new-notes (append new-notes (list (car old-notes)))))
 
164
      (setq old-notes (cdr old-notes)))
 
165
    (bbdb-record-set-raw-notes new-record new-notes))
 
166
  ;; return
 
167
  new-record)
 
168
 
 
169
(defun bbdb-ensure-list (foo)
 
170
  (if (lisp foo) foo
 
171
    (list foo)
 
172
    )
 
173
  )
 
174
 
 
175
(defun bbdb-zulu (date)
 
176
  (if (fboundp 'bbdb-time-convert)
 
177
      (bbdb-time-convert date "%Y%m%d%H%Mz")
 
178
    date ;; bbdb1.51 does not use it anyway.
 
179
    )
 
180
)
 
181
 
 
182
(defun bbdb-unzulu (date)
 
183
  (if (eq (length date) 13)
 
184
      (format "%s-%s-%s" (substring date 0 4) (substring date 4 6) (substring date  6 8))
 
185
    date)
 
186
)
 
187
(defun bbdb-ldif-indent (str)
 
188
  (if (> (length str)  70)
 
189
      (concat (substring str 0 65) "\n " (bbdb-ldif-indent (substring str 65)))
 
190
    str)
 
191
)
 
192
 
 
193
(defun addnote (nrec nname note)
 
194
  (bbdb-record-set-raw-notes
 
195
   nrec (cons (cons nname note)  (bbdb-record-raw-notes nrec)  )
 
196
   )
 
197
  )
 
198
 
 
199
(defmacro alias-update ()
 
200
  (if (fboundp 'bbdb-define-all-aliases) (list 'bbdb-define-all-aliases))
 
201
)
 
202
 
 
203
(defmacro alias-setup ()
 
204
  (if (fboundp 'mail-aliases-setup) (list 'mail-aliases-setup))
 
205
)
 
206
 
 
207
(defmacro domailaliases ()
 
208
  (fboundp 'mail-aliases-setup)
 
209
)
 
210
 
 
211
 
 
212
(defmacro dodenote (st)
 
213
  (if (fboundp 'base64-decode-string)
 
214
      (list 'base64-decode-string  st)
 
215
    "?"
 
216
    )
 
217
)
 
218
 
 
219
(defun addtonote (ton str)
 
220
  (cond
 
221
   ((and ton str) (concat ton "\n" str))
 
222
   (str (concat "--bbdb--\n" str))
 
223
   (ton)
 
224
   )
 
225
  )
 
226
 
 
227
(defun setaddr (nrec afun val)
 
228
  (if (not (bbdb-record-addresses nrec))
 
229
      (let ((addr(make-vector bbdb-address-length "")))
 
230
    (bbdb-record-set-addresses nrec (list addr))
 
231
    (bbdb-address-set-location addr "address")
 
232
    )
 
233
    )
 
234
  (eval (list afun (car (bbdb-record-addresses nrec)) val))
 
235
  )
 
236
 
 
237
 
 
238
(defun setphone (nrec iloc pno np)
 
239
  (let ((nov (bbdb-parse-phone-number pno))
 
240
    (pv (make-vector bbdb-phone-length ""))
 
241
    (ploc iloc)
 
242
    )
 
243
    (if (and np (equal  (car np) (concat bbdb-ldif-prefixh "PhoneLoc")))
 
244
    (setq ploc (cdr np))
 
245
      )
 
246
 
 
247
  (if (and nov bbdb-north-american-phone-numbers-p)
 
248
      (progn
 
249
    (bbdb-phone-set-location pv ploc)
 
250
    (bbdb-phone-set-area pv (nth 0 nov))
 
251
    (bbdb-phone-set-exchange pv (nth 1 nov))
 
252
    (bbdb-phone-set-suffix pv (nth 2 nov))
 
253
    (bbdb-phone-set-extension pv (or (nth 3 nov) 0))
 
254
    )
 
255
    (setq pv (vector ploc pno))
 
256
    )
 
257
  (bbdb-record-set-phones nrec(append (bbdb-record-phones nrec)(list pv)))
 
258
  )
 
259
  )
 
260
 
 
261
(defun bbdb-string-fetch (key mls)
 
262
  (let ((tmls  (car mls)) res)
 
263
    (while (and (not res) (car tmls))
 
264
      (if (string-match (format "%s= *\\(.+\\)" key) (car tmls))
 
265
      (setq res (match-string 1 (car tmls))))
 
266
      (setq tmls (cdr tmls)))
 
267
    res
 
268
    )
 
269
  )
 
270
 
 
271
(defun bbdb-ldif-get-phone (atts df)
 
272
  (if (and (cdr atts) (equal (concat bbdb-ldif-prefixh "phoneloc") (caadr atts)))
 
273
      (cdr (cadr atts))
 
274
    df)
 
275
)
 
276
 
 
277
(defun bbdb-import-ldif ()
 
278
  "import LDIF entries for current buffer
 
279
Mailinglists \(groupOfNames\) are imported as entries in bbdb mail-alias fields."
 
280
  (interactive)
 
281
;    (message (concat  (/(* 100 (point)) (point-max)) " pct\n"))
 
282
;;    (message (concat "\nnew rec  at" (point)))
 
283
  (let ((reclist (split-string (buffer-substring 1 (point-max)) "\n[ \t\r]*\n"))
 
284
    (numr 0) maxr (opct 0) pct mailinglists (emptyrec (make-vector bbdb-record-length nil))
 
285
    )
 
286
    (setq maxr (length reclist))
 
287
    (mapcar
 
288
     (lambda (rec)
 
289
       (if (not (equal "" rec))
 
290
       (let (
 
291
         (atts (mapcar (lambda (at)
 
292
                 (if (equal (string-to-char at) ?\ )
 
293
                 (cons 'continuation (substring at 1))
 
294
                   (let ( (cpos  (string-match ":" at)))
 
295
                 (if cpos
 
296
                     (let ((cpos2 ( string-match "[^ \t]"  at (1+ cpos))))
 
297
                       (if cpos2
 
298
                       (cons (substring at 0 cpos) (substring at cpos2))
 
299
                     )
 
300
                       )
 
301
                   )
 
302
                 )
 
303
                   )
 
304
                 )
 
305
               (split-string  rec "[\n\r]+"))
 
306
           )
 
307
         )
 
308
     (setq pct (/ (* 100 numr) maxr))
 
309
     (if (/= opct pct)
 
310
         (progn
 
311
           (setq opct pct)
 
312
           (message (concat  pct " pct"))
 
313
           )
 
314
       )
 
315
     (setq numr (1+ numr))
 
316
 
 
317
     (if (member '("objectclass" . "groupOfNames") atts)
 
318
         (let (mlcn lmlist)
 
319
           (while atts
 
320
         (if (car atts)
 
321
             (let ((attName (downcase (caar atts)))
 
322
               (attVal (cdar atts))
 
323
               )
 
324
               (while (and (cdr atts) (equal (caadr atts) 'continuation))
 
325
             (setq atts (cdr atts))
 
326
             (setq attVal (concat attVal (cdar atts)))
 
327
             )
 
328
               (if (equal (string-to-char  attVal)  ?:)
 
329
                   (setq attVal (dodenote (substring attVal (string-match "[^: \t]" attVal)))))
 
330
 
 
331
               (cond
 
332
            ((or (equal attName "cn") (equal attName "commonname")) (setq mlcn attVal))
 
333
            ((equal attName "member")
 
334
             (setq lmlist (cons  (bbdb-split attVal ",") lmlist))
 
335
             )
 
336
            )
 
337
               )
 
338
           )
 
339
         (setq atts (cdr atts))
 
340
         ) ; while
 
341
           (setq mailinglists (cons (cons mlcn lmlist) mailinglists))
 
342
           )
 
343
       (let (
 
344
         (new-record   (make-vector bbdb-record-length nil)))
 
345
         (while  atts
 
346
           (if (stringp (car-safe (car-safe atts)))
 
347
         (let (
 
348
               (attName (downcase (caar atts)))
 
349
               (attVal (cdar atts))
 
350
               (nextAtt  (car-safe (cdr-safe atts)))
 
351
               )
 
352
 
 
353
           (while (and (cdr atts) (equal (caadr atts) 'continuation))
 
354
             (setq atts (cdr atts))
 
355
             (setq attVal (concat attVal (cdar atts)))
 
356
             )
 
357
           (if (equal (string-to-char  attVal)  ?:)
 
358
               (setq attVal
 
359
                 (dodenote (substring attVal (string-match "[^: \t]" attVal))))
 
360
               )
 
361
         (cond
 
362
          ;((or (equal attName "cn") (equal attName "commonname")) hmm)
 
363
          ((or (equal attName "sn") (equal attName "surname")) (bbdb-record-set-lastname new-record attVal))
 
364
          ((equal attName "givenname") (bbdb-record-set-firstname new-record attVal))
 
365
          ((equal attName "o") (bbdb-record-set-company new-record attVal))
 
366
          ((equal attName "locality") (setaddr new-record 'bbdb-address-set-city  attVal))
 
367
          ((equal attName "postalcode") (setaddr new-record 'bbdb-address-set-zip attVal))
 
368
          ((equal attName "st") (setaddr new-record 'bbdb-address-set-state  attVal))
 
369
          ((equal attName (concat bbdb-ldif-prefixh "mainaddrloc"))
 
370
           (setaddr new-record 'bbdb-address-set-location attVal))
 
371
 
 
372
          ;; This is ugly. But is it the only way Netscape understands.
 
373
          ((equal attName "postofficebox") (setaddr new-record 'bbdb-address-set-street1 attVal))
 
374
          ((equal attName "streetaddress") (setaddr new-record 'bbdb-address-set-street2  attVal))
 
375
 
 
376
          ((equal attName "mail")
 
377
           (bbdb-record-set-net new-record (cons attVal (bbdb-record-net new-record))))
 
378
 
 
379
          ((equal attName "mailalternateaddress")
 
380
           (bbdb-record-set-net new-record (append  (bbdb-record-net  new-record)
 
381
                                (list attVal)))
 
382
           )
 
383
 
 
384
          ((equal attName "postaladdress")
 
385
           (let (
 
386
             (alines (split-string (concat (bbdb-ldif-renl attVal) "\n")"[\n\r]"))
 
387
             (addr (make-vector bbdb-address-length "")))
 
388
             (if (and (string-match "^bbdb=" (nth 0 alines ))
 
389
                  (> (length alines) 6))
 
390
             (progn
 
391
               (bbdb-address-set-location addr (substring (nth 0 alines) 5))
 
392
               (bbdb-address-set-street1 addr (nth 1 alines))
 
393
               (bbdb-address-set-street2 addr (nth 2 alines))
 
394
               (bbdb-address-set-street3 addr (nth 3 alines))
 
395
               (bbdb-address-set-zip addr (nth 4 alines))
 
396
               (bbdb-address-set-city addr (nth 5 alines))
 
397
               (bbdb-address-set-state addr (nth 6 alines))
 
398
               (bbdb-record-set-addresses
 
399
                new-record
 
400
                (append (bbdb-record-addresses new-record) (list addr))
 
401
                )
 
402
               )
 
403
               )
 
404
             )
 
405
           )
 
406
 
 
407
 
 
408
          ((equal attName "homephone")
 
409
           (setphone new-record (bbdb-ldif-get-phone atts "Private") attVal nextAtt) )
 
410
          ((equal attName "facsimiletelephonenumber")
 
411
           (setphone new-record (bbdb-ldif-get-phone atts "Fax") attVal nextAtt))
 
412
          ((equal attName "pagerphone")
 
413
           (setphone new-record (bbdb-ldif-get-phone atts "pagerphone") attVal nextAtt))
 
414
          ((equal attName "cellphone")
 
415
           (setphone new-record (bbdb-ldif-get-phone atts "cellphone") attVal nextAtt))
 
416
          ((equal attName "mobiletelephonenumber")
 
417
           (setphone new-record (bbdb-ldif-get-phone atts "cellphone") attVal nextAtt))
 
418
          ((equal attName "telephonenumber")
 
419
           (setphone new-record (bbdb-ldif-get-phone atts "Work") attVal nextAtt))
 
420
          ((equal attName "xmozillanickname") (bbdb-record-set-aka  new-record (list attVal)))
 
421
          ((or (equal attName "description") (equal attName "multilinedescription"))
 
422
           (if (equal attName "multilinedescription")
 
423
               (setq attVal (bbdb-ldif-renl attVal)))
 
424
           (let ((thenote (substring attVal 0  (string-match "\n?--bbdb--\n" attVal))))
 
425
             (if (not (equal "" thenote))
 
426
             (addnote new-record 'notes  thenote)
 
427
             )
 
428
           )
 
429
           )
 
430
 
 
431
          ((equal attName "createTimestamp")
 
432
           (addnote new-record 'creation-date (bbdb-unzulu attVal)))
 
433
          ((equal attName "modifyTimestamp")
 
434
           (addnote new-record 'timestamp (bbdb-unzulu attVal)))
 
435
          ((eq  (string-match bbdb-ldif-prefix attName) 0)
 
436
           (let (
 
437
             (bbdb-ldif-note (make-symbol (substring attName (length bbdb-ldif-prefix)))))
 
438
             (bbdb-record-set-raw-notes new-record
 
439
                        (cons (cons bbdb-ldif-note attVal)
 
440
                              (bbdb-record-raw-notes new-record)))
 
441
             )
 
442
           )
 
443
          )
 
444
         )
 
445
         )
 
446
           (setq atts (cdr atts))
 
447
           )
 
448
       ;  (print new-record)
 
449
         (if (not (equal new-record emptyrec))
 
450
         (progn
 
451
           (bbdb-record-set-cache new-record (make-vector bbdb-cache-length nil))
 
452
           (let      ((old-record
 
453
;;               (and (bbdb-record-net new-record)
 
454
                  (bbdb-search-simple (tnsnil (bbdb-record-name new-record))
 
455
                              (car (bbdb-record-net new-record)))
 
456
;;                )
 
457
                 )
 
458
                  )
 
459
           (if old-record
 
460
               (progn
 
461
             (setq new-record (bbdb-merge-internally-ldif old-record new-record))
 
462
             (bbdb-delete-record-internal old-record)))
 
463
           ;; create  new record
 
464
           (bbdb-invoke-hook 'bbdb-create-hook new-record)
 
465
           (bbdb-change-record new-record t)
 
466
           (bbdb-hash-record new-record)
 
467
           )
 
468
           )
 
469
           )
 
470
         )
 
471
       )
 
472
 
 
473
     )
 
474
     ) ; if
 
475
     ) ; lambda
 
476
     reclist
 
477
     )
 
478
    (mapcar
 
479
     (lambda (mlist)
 
480
       (let (
 
481
         (mlcn (car mlist)) (lmlist (cdr mlist)))
 
482
     (if mlcn
 
483
         (while lmlist
 
484
           (let (
 
485
             (mnet (bbdb-string-fetch"mail"   lmlist))
 
486
             (mname (bbdb-string-fetch"cn" lmlist))
 
487
             (mcomp (bbdb-string-fetch"o"  lmlist))
 
488
;;           (mou (bbdb-string-fetch"ou" lmlist))
 
489
             (therecs (bbdb-records))
 
490
             therec
 
491
             mal
 
492
             )
 
493
          (if mnet (setq therecs (bbdb-search therecs nil nil mnet nil)))
 
494
         (if mname (setq therecs (bbdb-search therecs mname nil nil nil )))
 
495
         (if mcomp (setq therecs (bbdb-search therecs nil mcomp nil nil nil )))
 
496
 
 
497
         (cond ((not therecs)
 
498
            (message (concat "Mailing list member not found: " mname " " mnet)))
 
499
               ((= (length therecs) 1)
 
500
            (setq therec (car therecs))
 
501
            (setq mal  (assq 'mail-alias (bbdb-record-raw-notes therec)))
 
502
            (if (not mal)
 
503
                (progn
 
504
                  (setq mal (cons 'mail-alias ""))
 
505
                  (bbdb-record-set-raw-notes therec (cons mal (bbdb-record-raw-notes therec))))
 
506
              (bbdb-change-record therec nil)
 
507
              (bbdb-hash-record therec)
 
508
              )
 
509
            (if (not (member mlcn (split-string (cdr mal) "[, ]")))
 
510
                (setcdr mal (concat mlcn (if (>  (length  (cdr-safe mal)) 0) "," "") (cdr mal) )))
 
511
            )
 
512
         (t  (message "Mailing List member not unique %s, %s"  mname mnet))
 
513
         )
 
514
         )
 
515
           (setq lmlist (cdr lmlist))
 
516
           )
 
517
                    ;          (define-mail-alias cn lmlist)
 
518
       )
 
519
     )
 
520
       )
 
521
     mailinglists
 
522
     )
 
523
    )
 
524
(message nil)
 
525
)
 
526
 
 
527
 
 
528
 
 
529
(defun rmspace (str)
 
530
  (apply 'concat (bbdb-split str "\n\r")))
 
531
 
 
532
(defun bbdb-ldif-replace-string (str frs tos)
 
533
  (let ((start 0))
 
534
    (while (string-match frs str start)
 
535
      (setq str
 
536
        (concat (substring str 0 (match-beginning 0))
 
537
            tos
 
538
            (substring str (match-end 0))))
 
539
          (setq start (+  (length tos) (match-beginning 0))))
 
540
    )
 
541
str
 
542
)
 
543
 
 
544
 
 
545
(defun bbase64-encode-string (st)
 
546
  (concat ":" (bbdb-ldif-indent (rmspace  st))
 
547
      )
 
548
  )
 
549
 
 
550
(defun bbdb-ldif-rmnl (str)
 
551
  (bbdb-ldif-replace-string (bbdb-ldif-replace-string str "\\$" "\\24") "\n" "$")
 
552
)
 
553
 
 
554
(defun bbdb-ldif-renl (str)
 
555
  (bbdb-ldif-replace-string (bbdb-ldif-replace-string str "\\$" "\n") "\\\\24" "$")
 
556
)
 
557
 
 
558
(defmacro donote (st)
 
559
  (if (fboundp 'base64-encode-string)
 
560
      (list 'bbase64-encode-string (list 'base64-encode-string st))
 
561
    (list 'bbdb-ldif-rmnl st)
 
562
    )
 
563
)
 
564
 
 
565
(defun base64IfMulti (st)
 
566
  (if (string-match "\n" st)
 
567
      (donote st)
 
568
    (concat " " (bbdb-ldif-indent st))
 
569
  )
 
570
)
 
571
 
 
572
(defun nsloc (pl) "Guess mapping from userdefined bbdb locations to NS Work/Home/Fax"
 
573
  (let (
 
574
    (pld (and pl (downcase pl)))
 
575
    (fc (and pl (not (equal pl "")) (string-to-char (downcase pl))))
 
576
    )
 
577
    (cond  ( (not fc)   "telephonenumber")
 
578
        ((or (= fc ?a) (= fc ?w))  "telephonenumber")
 
579
       ( (= fc ?h)  "homephone")
 
580
;;     ( (= fc ?m)  "mobileTelephoneNumber")
 
581
       ( (equal pld "private")  "homephone")
 
582
       ( (= fc ?m)  "cellphone")
 
583
       ( (and (= fc ?p) (> (length pld) 1) (= (aref  pld 1) ?a)) "pagerphone")
 
584
       ( (equal pld "fax")  "facsimiletelephonenumber")
 
585
       ( t  "telephonenumber")
 
586
       )
 
587
    )
 
588
)
 
589
 
 
590
(defun tnil(tt)
 
591
  (if tt tt "?"))
 
592
 
 
593
(defvar ldifbuffer "*LDIF*" "Name of buffer for LDIF output")
 
594
 
 
595
(defun bbdb-to-ldif (visible-records) "Converts BBDB to LDIF format. Can be used to export bbdb to Netscape
 
596
Communicator Address book.\\<bbdb-mode-map>
 
597
If \"\\[bbdb-apply-next-command-to-all-records]\\[bbdb2ldif]\" is \
 
598
used instead of simply \"\\[bbdb2ldif]\", then includes only the
 
599
people currently in the *BBDB* buffer.
 
600
The result is placed in a buffer name \"*LDIF*\"
 
601
If  MEL is installed Multiline notes/descriptions work with Netscape address book.
 
602
Mail-aliases from mailrc file or bbdb mail-aliases fields are exported as mainglists
 
603
\(GroupOfNames\)
 
604
"
 
605
  (interactive (list
 
606
        (bbdb-do-all-records-p)
 
607
        )
 
608
           )
 
609
  (let* (
 
610
     (target (cons bbdb-define-all-aliases-field "."))
 
611
     (ldif-records
 
612
      (bbdb-search
 
613
       (if (not visible-records)
 
614
           (bbdb-records)
 
615
         (mapcar 'car bbdb-records)
 
616
         )
 
617
       nil nil nil target)
 
618
      )
 
619
     tmps
 
620
     record
 
621
     )
 
622
 
 
623
 
 
624
    (setq ldif-records
 
625
      (if (not visible-records)
 
626
          (bbdb-records)
 
627
        (mapcar 'car bbdb-records)
 
628
        )
 
629
      )
 
630
 
 
631
    (set-buffer (get-buffer-create ldifbuffer))
 
632
    (setq fill-column 1000)
 
633
    (erase-buffer)
 
634
 
 
635
    (while ldif-records
 
636
      (setq record (car ldif-records))
 
637
      (insert "\nxmozillausehtmlmail: FALSE\n")
 
638
      (let (
 
639
        (net (car (bbdb-record-net record)))
 
640
        (rnet  (bbdb-record-net record))
 
641
        )
 
642
    (insert (format "dn: cn=%s"  (tnil (bbdb-record-name record))))
 
643
    (if net
 
644
        (insert (format ",mail=%s" net))
 
645
        )
 
646
    (insert "\n")
 
647
 
 
648
    (setq tmps (bbdb-record-firstname record)) (insert "givenname: "  (tnil tmps) "\n")
 
649
    (setq tmps (bbdb-record-lastname record))   (if tmps (insert "sn: "  tmps "\n"))
 
650
    (insert "objectclass: top\nobjectclass: person\n")
 
651
    (setq tmps (bbdb-record-company record))    (if tmps (insert "o: " tmps "\n"))
 
652
    (setq tmps (bbdb-record-name record))   (if tmps (insert "cn: "  tmps "\n"))
 
653
 
 
654
    (if net (insert "mail: " net "\n"))
 
655
    (while (cdr rnet)
 
656
      (insert "mailAlternateAddress: " (cadr rnet) "\n")
 
657
      (setq rnet (cdr rnet))
 
658
      )
 
659
    )
 
660
      (let (
 
661
        (phones (bbdb-record-phones record))
 
662
        (addrs (bbdb-record-addresses record))
 
663
        (aka (bbdb-record-aka record))
 
664
        (firstaddr t)
 
665
        tonote
 
666
        phone
 
667
        (elide nil)
 
668
        )
 
669
 
 
670
    (while phones
 
671
      (setq phone (car phones))
 
672
      (if (equal (nsloc (bbdb-phone-location phone))"cellphone")
 
673
          (setq tonote (addtonote tonote (concat "M:" (bbdb-phone-string phone) )))
 
674
        )
 
675
      (if (equal (nsloc (bbdb-phone-location phone))"pagerphone")
 
676
          (setq tonote (addtonote tonote (concat "P:" (bbdb-phone-string phone) )))
 
677
        )
 
678
      (insert (format "%s: " (nsloc (bbdb-phone-location phone))) (bbdb-phone-string phone) "\n")
 
679
      (insert bbdb-ldif-prefixh "PhoneLoc:" (bbdb-phone-location  phone)"\n")
 
680
      (setq phones (cdr phones)))
 
681
 
 
682
    (let (addr tmps)
 
683
      (while  addrs
 
684
        (setq addr (car addrs))
 
685
        (if firstaddr (progn
 
686
        (if (= 0 (length (setq tmps (bbdb-address-street1 addr)))) nil  (insert "postOfficeBox: " tmps "\n"))
 
687
        (if (= 0 (length (setq tmps (bbdb-address-street2 addr)))) nil  (insert "streetaddress: " tmps "\n"))
 
688
        (if (= 0 (length (setq tmps (bbdb-address-street3 addr)))) nil  (insert "streetaddress: " tmps "\n" ))
 
689
 
 
690
       ; This does not work with Netscape
 
691
       ; (if (= 0 (length (setq tmps (bbdb-address-street1 addr)))) nil  (insert "homePostalAddress:" tmps ))
 
692
       ; (if (= 0 (length (setq tmps (bbdb-address-street2 addr)))) nil  (insert "$" tmps))
 
693
       ; (if (= 0 (length (setq tmps (bbdb-address-street3 addr)))) nil  (insert "$" tmps ))
 
694
       ; (insert "\n")
 
695
 
 
696
        (insert "locality:"  (bbdb-address-city addr) "\n")
 
697
        (setq tmps (bbdb-address-state addr))
 
698
        (if (and tmps (not (equal tmps ""))) (insert "st:" tmps "\n"))
 
699
        (if (bbdb-address-zip-string addr)
 
700
            (insert "postalcode:" (bbdb-address-zip-string addr) "\n"))
 
701
        (setq firstaddr nil)
 
702
        )
 
703
          (progn
 
704
        (setq tonote (addtonote tonote (concat (bbdb-address-street1 addr))))
 
705
        (setq tonote (addtonote tonote (concat (bbdb-address-street2 addr))))
 
706
        (setq tonote (addtonote tonote (concat (bbdb-address-street3 addr))))
 
707
        (setq tonote (addtonote tonote (concat  (bbdb-address-zip-string addr) " "  (bbdb-address-city addr) )))
 
708
        (insert (concat "postalAddress: "
 
709
                (base64IfMulti (concat "bbdb=" (bbdb-address-location addr)  "\n"
 
710
                               (bbdb-address-street1 addr)  "\n"
 
711
                               (bbdb-address-street2 addr)  "\n"
 
712
                               (bbdb-address-street3 addr) "\n"
 
713
                               (bbdb-address-zip-string addr) "\n"
 
714
                               (bbdb-address-city addr) "\n"
 
715
                               (bbdb-address-state addr)
 
716
                               )
 
717
                           )
 
718
                "\n"
 
719
                )
 
720
            )
 
721
        )
 
722
          )
 
723
        (setq addrs (cdr addrs)))
 
724
      )
 
725
    (cond (aka
 
726
           (insert (format "%s: %s\n" "xmozillanickname"
 
727
                   (mapconcat (function identity) aka ", ")))
 
728
           ))
 
729
    (let ((notes (bbdb-record-raw-notes record)))
 
730
      (if (stringp notes)
 
731
          (setq notes (list (cons 'notes notes))))
 
732
      (while notes
 
733
        (setq elide nil)
 
734
        (cond
 
735
         ((member (caar notes) bbdb-elided-export-ldif) (setq elide t))
 
736
         ((eq (car (car notes)) 'creation-date)
 
737
          (insert "createTimestamp: " (bbdb-zulu (cdar notes))"\n")
 
738
          (setq elide t)
 
739
          )
 
740
         ((eq (car (car notes)) 'timestamp)
 
741
          (setq elide t)
 
742
          (insert "modifyTimestamp: "(bbdb-zulu (cdar notes))"\n")
 
743
          )
 
744
         ((eq (car (car notes)) 'notes)  (setq elide t))
 
745
         ((eq (car (car notes)) 'mail-alias)  (setq elide t))
 
746
         (t
 
747
        ;; Netscape cannot display this. So we also put it in the notes field.
 
748
        (setq tonote (addtonote tonote (format "%s:%s" (caar notes)   (cdar notes))))
 
749
        (insert (format "%s%s:" bbdb-ldif-prefix (car (car notes))))
 
750
         )
 
751
          )
 
752
        (if (eq (caar notes) 'notes)
 
753
        (if tonote
 
754
            (setq tonote (concat (cdar notes) "\n" tonote))
 
755
          (setq tonote  (cdar notes)))
 
756
          (if (not elide)
 
757
          (insert (base64IfMulti (tnil (cdar notes))) "\n"))
 
758
          )
 
759
        (setq notes (cdr notes))
 
760
        )
 
761
      (if tonote
 
762
          (if (and (string-match "\n" tonote) (not (fboundp 'base64-encode-string)))
 
763
          (insert "multilineDescription:" (bbdb-ldif-rmnl tonote ) "\n")
 
764
          (insert "description:" (base64IfMulti tonote ) "\n")
 
765
          )
 
766
        )
 
767
      )
 
768
    (if (bbdb-record-addresses record)
 
769
        (insert bbdb-ldif-prefixh "mainAddrLoc:" (bbdb-address-location (car (bbdb-record-addresses record)))"\n")
 
770
        )
 
771
 
 
772
    )
 
773
      (setq ldif-records (cdr ldif-records))
 
774
      )
 
775
    )
 
776
  (if (and (not visible-records) (domailaliases))
 
777
      (progn
 
778
    (alias-update)
 
779
    (alias-setup)
 
780
    ;;      (bbdb-define-all-aliases)
 
781
    (let ((mai 0) mae alist (malen (length mail-aliases)
 
782
                     ))
 
783
    (while (< mai malen)
 
784
      (setq mae (aref mail-aliases mai) )
 
785
      (if (and mae (symbolp mae ))
 
786
          (progn
 
787
        (insert (format "\ndn: cn=%s\n"  mae))
 
788
        (insert (format "cn: %s\n"  mae))
 
789
        (insert "objectclass: top\n")
 
790
        (insert "objectclass: groupOfNames\n")
 
791
        (setq alist (symbol-value mae ))
 
792
        (if alist
 
793
             (mapcar
 
794
              (lambda (an)
 
795
            (let ((trec (bbdb-search-simple nil an))
 
796
                  )
 
797
              (if trec
 
798
              (insert (format "member: cn=%s,mail=%s\n"
 
799
                      (tnil (bbdb-record-name trec))
 
800
                      (tnil (car (bbdb-record-net trec)))
 
801
                      )
 
802
                  )
 
803
              )
 
804
              )
 
805
            )
 
806
              (split-string alist ", ")
 
807
              )
 
808
             )
 
809
        )
 
810
        )
 
811
      (setq mai (1+ mai))
 
812
      )
 
813
    )
 
814
    )
 
815
    (alias-update)
 
816
    )
 
817
  (set-window-buffer (get-lru-window) ldifbuffer )
 
818
)
 
819
;;(add-hook 'bbdb-load-hook (lambda () (define-key bbdb-mode-map "L"      'bbdb-to-ldif)))
 
820
(define-key bbdb-mode-map "L"      'bbdb-to-ldif)
 
821
(provide 'bbdb-ldif)