home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / languages / elisp / packages / bbdb / bbdb-ftp.el < prev    next >
Encoding:
Text File  |  1992-04-22  |  7.2 KB  |  184 lines
  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@lucid.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. ;;; $Date: 1992/04/22 21:22:53 $ by $Author: ivan $
  25. ;;; $Revision: 1.4 $
  26.  
  27. ;;; This file adds the ability to define ftp-sites in a BBDB, much the
  28. ;;; same way one adds a regular person's name to the BBDB.  It also
  29. ;;; defines the bbdb-ftp command which allows you to ftp a site that
  30. ;;; is in a bbdb-record.  This code relies on ange-ftp and will not
  31. ;;; work without it.  Ange-ftp is available at
  32. ;;; archive.cis.ohio-state.edu in the
  33. ;;; /pub/gnu/emacs/elisp-archive/packages directory.
  34.  
  35. ;;; Note that Ftp Site BBDB entries differ from regular entries by the
  36. ;;; fact that the Name Field must have the ftp site preceeded by the
  37. ;;; bbdb-ftp-site-name-designator-prefix.  This defaults to "Ftp Site:" 
  38. ;;; BBDB Ftp Site entries also have two new fields added, the
  39. ;;; ftp-dir slot, and the ftp-user slot.  These are added to the notes
  40. ;;; alist part of the bbdb-records, the original bbdb-record structure
  41. ;;; remains untouched.
  42.  
  43. ;;; The following user-level commands are defined for use:
  44. ;;;
  45.  
  46. ;;; bbdb-ftp - Use ange-ftp to open an ftp-connection to a BBDB
  47. ;;;            record's name.  If this command is executed from the
  48. ;;;            *BBDB* buffer, ftp the site of the record at point;
  49. ;;;            otherwise, it prompts for an ftp-site. 
  50.  
  51. ;;; bbdb-create-ftp-site -
  52. ;;;            Add a new ftp-site entry to the bbdb database; prompts
  53. ;;;            for all relevant info using the echo area, inserts the
  54. ;;;            new record in the db, sorted alphabetically.
  55.  
  56. ;;; The package can be installed by compiling and adding the following
  57. ;;; two lines to your .emacs.
  58.  
  59. ;;; (autoload 'bbdb-ftp                 "bbdb-ftp"  "Ftp BBDB Package" t)
  60. ;;; (autoload 'bbdb-create-ftp-site     "bbdb-ftp"  "Ftp BBDB Package" t)
  61.  
  62. (require 'bbdb)
  63. (require 'ange-ftp)
  64.  
  65. (defvar bbdb-default-ftp-user "anonymous"
  66.   "*The default login to use when ftp-ing.")
  67.  
  68. (defvar bbdb-default-ftp-dir "/"
  69.   "*The default directory to open when ftp-ing.")
  70.  
  71. (defvar bbdb-ftp-site-name-designator-prefix "Ftp Site: "
  72.   "*The prefix that all ftp sites in the bbdb will have in their name field.")
  73.  
  74. (defmacro defun-bbdb-raw-notes-accessor (slot)
  75.   "Expands into an accessor function for slots in the notes alist."
  76.   (let ((fn-name (intern (concat "bbdb-record-" (symbol-name slot)))))
  77.     (list 'defun fn-name (list 'record)
  78.       (list 'cdr 
  79.         (list 'assoc (list 'quote slot)
  80.               (list 'bbdb-record-raw-notes 'record))))))
  81.  
  82. (defun-bbdb-raw-notes-accessor ftp-dir) 
  83. (defun-bbdb-raw-notes-accessor ftp-user)
  84.  
  85. (defun bbdb-record-ftp-site (record)
  86.   "Acessor Function. Returns the ftp-site field of the BBDB record or nil."
  87.   (let* ((name (bbdb-record-name record))
  88.      (ftp-pfx-regexp (concat bbdb-ftp-site-name-designator-prefix " *"))
  89.      (ftp-site 
  90.       (and (string-match ftp-pfx-regexp name) 
  91.            (substring name (match-end 0)))))
  92.     ftp-site))
  93.  
  94. (defun remove-leading-whitespace (string)
  95.   "Remove any spaces or tabs from only the start of the string."
  96.   (let ((space-char-code (string-to-char " "))
  97.     (tab-char-code   ?\t)
  98.     (index 0))
  99.     (if string
  100.     (progn 
  101.       (while (or (char-equal (elt string index) space-char-code)
  102.              (char-equal (elt string index) tab-char-code))
  103.         (setq index (+ index 1)))
  104.       (substring string index))
  105.       nil)))
  106.  
  107. (defun bbdb-ftp (bbdb-record)
  108.   "Use ange-ftp to open an ftp-connection to a BBDB record's name.
  109. If this command is executed from the *BBDB* buffer, ftp the site of
  110. the record at point; otherwise, it prompts for an ftp-site.
  111. \\<bbdb-mode-map>"
  112.   (interactive (list (if (string= bbdb-buffer-name (buffer-name))
  113.              (bbdb-current-record)
  114.                (let (r (p "BBDB Ftp: "))
  115.              (while (not r)
  116.                (setq r (bbdb-completing-read-record p))
  117.                (if (not r) (ding))
  118.                (setq p "Not in the BBDB!  Ftp: "))
  119.              r))))
  120.   (if (not (consp bbdb-record)) (setq bbdb-record (list bbdb-record)))
  121.   (while bbdb-record
  122.     (bbdb-ftp-internal (car bbdb-record))
  123.     (setq bbdb-record (cdr bbdb-record))))
  124.  
  125. (defun bbdb-ftp-internal (bbdb-record)
  126.   (let* ((site (or (bbdb-record-ftp-site bbdb-record) ""))
  127.          (dir  (or (bbdb-record-ftp-dir bbdb-record) bbdb-default-ftp-dir))
  128.          (user (or (bbdb-record-ftp-user bbdb-record) bbdb-default-ftp-user))
  129.          (file-string (concat "/" user "@" site ":" dir )))
  130.     (if bbdb-inside-electric-display
  131.         (bbdb-electric-throw-to-execute (list 'bbdb-ftp-internal bbdb-record)))
  132.     (cond (site
  133.            (find-file-other-window file-string))
  134.           (t
  135.            (error
  136.             "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)
  146.     (bbdb-error-retry
  147.      (progn
  148.        (setq site (bbdb-read-string "Ftp Site: "))
  149.        (setq site (concat bbdb-ftp-site-name-designator-prefix site))
  150.        (if (bbdb-gethash (downcase site))
  151.         (error "%s is already in the database" site))))
  152.     (let* ((dir  (bbdb-read-string "Ftp Directory: "
  153.                    bbdb-default-ftp-dir))
  154.        (user  (bbdb-read-string "Ftp Username: "
  155.                     bbdb-default-ftp-user))
  156.        (company (bbdb-read-string "Company: "))
  157.        (notes (bbdb-read-string "Additional Comments: "))
  158.        (names  (bbdb-divide-name site))
  159.        (firstname (car names))
  160.        (lastname (nth 1 names)))
  161.       (if (string= user bbdb-default-ftp-user) (setq user nil))
  162.       (if (string= company "") (setq company nil))
  163.       (if (or (string= dir bbdb-default-ftp-dir) (string= dir ""))
  164.       (setq dir nil))
  165.       (if (string= notes "")   (setq notes nil))
  166.  
  167.       (let ((record
  168.          (vector firstname lastname nil company nil nil nil 
  169.              (append 
  170.               (if notes (list (cons 'notes notes)) nil)
  171.               (if dir   (list (cons 'ftp-dir dir)) nil)
  172.               (if user  (list (cons 'ftp-user user)) nil))
  173.              (make-vector bbdb-cache-length nil))))
  174.     record))))
  175.    
  176. (defun bbdb-create-ftp-site (record)
  177.   "Add a new ftp-site entry to the bbdb database; prompts for all relevant info
  178. using the echo area, inserts the new record in the db, sorted alphabetically."
  179.   (interactive (list (bbdb-read-new-ftp-site-record)))
  180.   (bbdb-invoke-hook 'bbdb-create-hook record)
  181.   (bbdb-change-record record t)
  182.   (bbdb-display-records (list record)))
  183.  
  184.