1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
|
;;; -*- Mode:Emacs-Lisp -*-
;;; This file is an addition to the Insidious Big Brother Database
;;; (aka BBDB), copyright (c) 1991, 1992 Jamie Zawinski
;;; <jwz@netscape.com>.
;;;
;;; The Insidious Big Brother Database is free software; you can redistribute
;;; it and/or modify it under the terms of the GNU General Public License as
;;; published by the Free Software Foundation; either version 1, or (at your
;;; option) any later version.
;;;
;;; BBDB 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 GNU Emacs; see the file COPYING. If not, write to
;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
;;; This file was written by Ivan Vazquez <ivan@haldane.bu.edu>
;;; $Id: bbdb-ftp.el,v 1.9 2007-02-23 20:24:07 fenk Exp $
;;; This file adds the ability to define ftp-sites in a BBDB, much the same
;;; way one adds a regular person's name to the BBDB. It also defines the
;;; bbdb-ftp command which allows you to ftp a site that is in a bbdb-record.
;;; You must have either EFS or ange-ftp in order to use this code. Ange-ftp
;;; is available at archive.cis.ohio-state.edu in the
;;; /pub/gnu/emacs/elisp-archive/packages directory. EFS ships with XEmacs.
;;; Note that Ftp Site BBDB entries differ from regular entries by the
;;; fact that the Name Field must have the ftp site preceeded by the
;;; bbdb-ftp-site-name-designator-prefix. This defaults to "Ftp Site:"
;;; BBDB Ftp Site entries also have two new fields added, the
;;; ftp-dir slot, and the ftp-user slot. These are added to the notes
;;; alist part of the bbdb-records, the original bbdb-record structure
;;; remains untouched.
;;; The following user-level commands are defined for use:
;;;
;;; bbdb-ftp - Use ange-ftp to open an ftp-connection to a BBDB
;;; record's name. If this command is executed from the
;;; *BBDB* buffer, ftp the site of the record at point;
;;; otherwise, it prompts for an ftp-site.
;;; bbdb-create-ftp-site -
;;; Add a new ftp-site entry to the bbdb database; prompts
;;; for all relevant info using the echo area, inserts the
;;; new record in the db, sorted alphabetically.
;;; The package can be installed by compiling and adding the following
;;; two lines to your .emacs.
;;; (autoload 'bbdb-ftp "bbdb-ftp" "Ftp BBDB Package" t)
;;; (autoload 'bbdb-create-ftp-site "bbdb-ftp" "Ftp BBDB Package" t)
(require 'bbdb)
;; There must be a better way
(if (featurep 'efs-cu)
(require 'efs)
(require 'ange-ftp))
(defcustom bbdb-default-ftp-user "anonymous"
"*The default login to use when ftp-ing."
:group 'bbdb-utilities-ftp
:type 'string)
(defcustom bbdb-default-ftp-dir "/"
"*The default directory to open when ftp-ing."
:group 'bbdb-utilities-ftp
:type 'string)
(defcustom bbdb-ftp-site-name-designator-prefix "Ftp Site: "
"*The prefix that all ftp sites in the bbdb will have in their name field."
:group 'bbdb-utilities-ftp
:type 'string)
(defmacro defun-bbdb-raw-notes-accessor (slot)
"Expands into an accessor function for slots in the notes alist."
(let ((fn-name (intern (concat "bbdb-record-" (symbol-name slot)))))
(list 'defun fn-name (list 'record)
(list 'cdr
(list 'assoc (list 'quote slot)
(list 'bbdb-record-raw-notes 'record))))))
(defun-bbdb-raw-notes-accessor ftp-dir)
(defun-bbdb-raw-notes-accessor ftp-user)
(defun bbdb-record-ftp-site (record)
"Accessor Function. Returns the ftp-site field of the BBDB record or nil."
(let* ((name (bbdb-record-name record))
(ftp-pfx-regexp (concat bbdb-ftp-site-name-designator-prefix " *"))
(ftp-site
(and (string-match ftp-pfx-regexp name)
(substring name (match-end 0)))))
ftp-site))
(defun remove-leading-whitespace (string)
"Remove any spaces or tabs from only the start of the string."
(let ((space-char-code (string-to-char " "))
(tab-char-code ?\t)
(index 0))
(if string
(progn
(while (or (char-equal (elt string index) space-char-code)
(char-equal (elt string index) tab-char-code))
(setq index (+ index 1)))
(substring string index))
nil)))
;;;###autoload
(defun bbdb-ftp (bbdb-record &optional which)
"Use ange-ftp to open an ftp-connection to a BBDB record's name.
If this command is executed from the *BBDB* buffer, ftp the site of
the record at point; otherwise, it prompts for an ftp-site."
(interactive (list (bbdb-get-record "Visit (FTP): ")
(or current-prefix-arg 0)))
(if (bbdb-record-ftp-site bbdb-record)
(bbdb-ftp-internal bbdb-record)
(find-file-other-window
(read-string "fetch: " (bbdb-get-field bbdb-record 'ftp which)))))
(defun bbdb-ftp-internal (bbdb-record)
(let* ((site (bbdb-record-ftp-site bbdb-record))
(dir (or (bbdb-record-ftp-dir bbdb-record) bbdb-default-ftp-dir))
(user (or (bbdb-record-ftp-user bbdb-record) bbdb-default-ftp-user))
(file-string (concat "/" user "@" site ":" dir )))
(if bbdb-inside-electric-display
(bbdb-electric-throw-to-execute (list 'bbdb-ftp-internal bbdb-record)))
(if site
(find-file-other-window file-string)
(error "Not an ftp site. Check bbdb-ftp-site-name-designator-prefix"))))
(defun bbdb-read-new-ftp-site-record ()
"Prompt for and return a completely new BBDB record that is
specifically an ftp site entry. Doesn't insert it in to the database
or update the hashtables, but does insure that there will not be name
collisions."
(bbdb-records) ; make sure database is loaded
(if bbdb-readonly-p (error "The Insidious Big Brother Database is read-only."))
(let (site dir user)
(bbdb-error-retry
(progn
(setq site (bbdb-read-string "Ftp Site: "))
;; try and parse it out, in case the user typed in things like
;; "ftp://user@site/directory/ or /user@site/directory
(if (string-match
"^\\([Ff][Tt][Pp]://\\|/\\)?\\([^@/]@\\)?\\([^/]+\\)\\(/[^/].*\\)?"
site)
(setq user (if (match-beginning 2)
(substring site (match-beginning 2)
(match-end 2)))
dir (if (match-beginning 4)
(substring site (match-beginning 4)
(match-end 4)))
site (substring site (match-beginning 3)
(match-end 3)))
(if (string-match "/" site)
(error "%s doesn't look like a valid site name." site)))
(setq site (concat bbdb-ftp-site-name-designator-prefix site))
(if (and bbdb-no-duplicates-p
(bbdb-gethash (downcase site)))
(error "%s is already in the database" site))))
(let* ((dir (or dir (bbdb-read-string "Ftp Directory: "
bbdb-default-ftp-dir)))
(user (or user (bbdb-read-string "Ftp Username: "
bbdb-default-ftp-user)))
(company (bbdb-read-string "Company: "))
(notes (bbdb-read-string "Additional Comments: "))
(names (bbdb-divide-name site))
(firstname (car names))
(lastname (nth 1 names)))
(if (string= user bbdb-default-ftp-user) (setq user nil))
(if (string= company "") (setq company nil))
(if (or (string= dir bbdb-default-ftp-dir) (string= dir ""))
(setq dir nil))
(if (string= notes "") (setq notes nil))
(let ((record
(vector firstname lastname nil company nil nil nil
(append
(if notes (list (cons 'notes notes)) nil)
(if dir (list (cons 'ftp-dir dir)) nil)
(if user (list (cons 'ftp-user user)) nil))
(make-vector bbdb-cache-length nil))))
record))))
;;;###autoload
(defun bbdb-create-ftp-site (record)
"Add a new ftp-site entry to the bbdb database.
Prompts for all relevant info using the echo area,
inserts the new record in the db, sorted alphabetically."
(interactive (list (bbdb-read-new-ftp-site-record)))
(bbdb-invoke-hook 'bbdb-create-hook record)
(bbdb-change-record record t)
(bbdb-display-records (list record)))
(provide 'bbdb-ftp)
|
