cgit.sxemacs.org Git - packages/blob - xemacs-packages/bbdb/lisp/bbdb-ftp.el

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