cgit.sxemacs.org Git - packages/blob - xemacs-packages/efs/efs-cu.el

   1 ;; -*-Emacs-Lisp-*-
   2 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   3 ;;
   4 ;; File:         efs-cu.el
   5 ;; Release:      $efs release: 1.24 $
   6 ;; Version:      #Revision: 1.13 $
   7 ;; RCS:
   8 ;; Description:  Common utilities needed by efs files.
   9 ;; Author:       Sandy Rutherford <sandy@ibm550.sissa.it>
  10 ;; Created:      Fri Jan 28 19:55:45 1994 by sandy on ibm550
  11 ;; Language:     Emacs-Lisp
  12 ;;
  13 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  14
  15 ;;; This file is part of efs. See efs.el for copyright
  16 ;;; (it's copylefted) and warranty (there isn't one) information.
  17
  18 ;;;; Provisions and autoloads.
  19
  20 (provide 'efs-cu)
  21 (require 'custom)
  22 (require 'backquote)
  23 (autoload 'efs-get-process "efs")
  24 (autoload 'efs-parse-netrc "efs-netrc")
  25
  26 ;;;; ------------------------------------------------------------
  27 ;;;; Use configuration variables.
  28 ;;;; ------------------------------------------------------------
  29
  30 (defvar efs-default-user "anonymous"
  31   "*User name to use when none is specied in a pathname.
  32
  33 If a string, than this string is used as the default user name.
  34 If nil, then the name under which the user is logged in is used.
  35 If t, then the user is prompted for a name.
  36 If an association list of the form
  37
  38    '((REGEXP1 . USERNAME1) (REGEXP2 . USERNAME2) ...)
  39
  40 then the host name is tested against each of the regular expressions
  41 REGEXP in turn, and the default user name is the corresponding value
  42 of USERNAME.  USERNAME may be either a string, nil, or t, and these
  43 values are interpreted as above.  If there are no matches, then the
  44 user's curent login name is used.")
  45
  46 (defvar efs-default-password nil
  47   "*Password to use when the user is the same as efs-default-user.")
  48
  49 (defvar efs-default-account nil
  50   "*Account password to use when the user is efs-default-user.")
  51
  52 ;;;; -------------------------------------------------------------
  53 ;;;; Internal variables.
  54 ;;;; -------------------------------------------------------------
  55
  56 (defconst efs-cu-version
  57   (concat (substring "$efs release: 1.24 $" 14 -2)
  58           "/"
  59           (substring "#Revision: 1.13 $" 11 -2)))
  60
  61 (defconst efs-case-insensitive-host-types
  62   '(vms cms mts ti-twenex ti-explorer dos mvs tops-20 mpe ka9q dos-distinct
  63     os2 hell guardian ms-unix netware cms-knet nos-ve)
  64   "List of host types for which case is insignificant in file names.")
  65
  66 ;;; Remote path name syntax
  67
  68 ;; All of the following variables must be set consistently.
  69 ;; As well the below two functions depend on the grouping constructs
  70 ;; in efs-path-regexp. So know what you're doing if you change them.
  71
  72 (defvar efs-path-regexp "^/\\([^:/]*@\\)?\\([^@:/]*\\):.*"
  73   "Regexp of a fully expanded remote path.")
  74
  75 (defvar efs-path-format-string "/%s@%s:%s"
  76   "Format of a fully expanded remote path. Passed to format with
  77 additional arguments user, host, and remote path.")
  78
  79 (defvar efs-path-format-without-user "/%s:%s"
  80   "Format of a remote path, but not specifying a user.")
  81
  82 (defvar efs-path-user-at-host-format
  83   (substring efs-path-format-string 1 7)
  84   "Format to return `user@host:' strings for completion in root directory.")
  85
  86 (defvar efs-path-host-format
  87   (substring efs-path-user-at-host-format 3)
  88   "Format to return `host:' strings for completion in root directory.")
  89
  90 ;;;###autoload
  91 (defvar efs-path-root-regexp "^/[^/:]+:"
  92   "Regexp to match the `/user@host:' root of an efs full path.")
  93
  94 (defvar efs-path-root-short-circuit-regexp "//[^/:]+:")
  95 ;; Regexp to match an efs user@host root, which short-circuits
  96 ;; the part of the path to the left of this pattern.
  97
  98 ;;;; -----------------------------------------------------------
  99 ;;;; Customization groups
 100 ;;;; -----------------------------------------------------------
 101
 102 (defgroup efs nil
 103   "Transparent ftp access."
 104   :group 'files)
 105
 106 (defgroup efs-behavior nil
 107   "User-visible aspects of EFS."
 108   :prefix "efs-"
 109   :group 'efs)
 110
 111 (defgroup efs-auto-save nil
 112   "EFS interaction with auto-save."
 113   :prefix "efs-"
 114   :group 'efs)
 115
 116 (defgroup efs-gateways nil
 117   "Using EFS via an ftp gateway."
 118   :prefix "efs-"
 119   :group 'efs)
 120
 121 (defgroup efs-programs nil
 122   "External programs used by EFS."
 123   :prefix "efs-"
 124   :group 'efs)
 125
 126 (defgroup efs-parameters nil
 127   "Behind-the-scenes parameters of EFS."
 128   :prefix "efs-"
 129   :group 'efs)
 130
 131 (defgroup efs-hooks nil
 132   "Hooks for EFS."
 133   :prefix "efs-"
 134   :group 'efs)
 135
 136 ;;;; -----------------------------------------------------------
 137 ;;;; Variables for multiple host type support
 138 ;;;; -----------------------------------------------------------
 139
 140 (defcustom efs-vms-host-regexp nil
 141   "Regexp to match the names of hosts running VMS."
 142   :group 'efs-parameters
 143   :type '(choice (const nil) regexp))
 144 (defcustom efs-cms-host-regexp nil
 145   "Regexp to match the names of hosts running CMS."
 146   :group 'efs-parameters
 147   :type '(choice (const nil) regexp))
 148 (defcustom efs-mts-host-regexp nil
 149   "Regexp to match the names of hosts running MTS."
 150   :group 'efs-parameters
 151   :type '(choice (const nil) regexp))
 152 (defcustom efs-ti-explorer-host-regexp nil
 153   "Regexp to match the names of hosts running TI-EXPLORER.
 154 These are lisp machines."
 155   :group 'efs-parameters
 156   :type '(choice (const nil) regexp))
 157 (defcustom efs-ti-twenex-host-regexp nil
 158   "Regexp to match the names of hosts running TI-TWENEX.
 159 These are lisp machines, and this should not be confused with DEC's TOPS-20."
 160   :group 'efs-parameters
 161   :type '(choice (const nil) regexp))
 162 (defcustom efs-sysV-unix-host-regexp nil
 163   "Regexp to match the names of sysV unix hosts.
 164 These are defined to be unix hosts which mark symlinks
 165 with a @ in an ls -lF listing."
 166   :group 'efs-parameters
 167   :type '(choice (const nil) regexp))
 168 (defcustom efs-bsd-unix-host-regexp nil
 169   "Regexp to match the names of bsd unix hosts.
 170 These are defined to be unix hosts which do not mark symlinks
 171 with a @ in an ls -lF listing."
 172   :group 'efs-parameters
 173   :type '(choice (const nil) regexp))
 174 (defcustom efs-next-unix-host-regexp nil
 175   "Regexp to match names of NeXT unix hosts.
 176 These are defined to be unix hosts which put a @ after the
 177 destination of a symlink when doing ls -lF listing."
 178   :group 'efs-parameters
 179   :type '(choice (const nil) regexp))
 180 (defcustom efs-unix-host-regexp nil
 181   "Regexp to match names of unix hosts.
 182 I you know which type of unix, it is much better to set that regexp instead."
 183   :group 'efs-parameters
 184   :type '(choice (const nil) regexp))
 185 (defcustom efs-dumb-unix-host-regexp nil
 186   "Regexp to match names of unix hosts which do not take ls switches.
 187 For these hosts we use the \"dir\" command."
 188   :group 'efs-parameters
 189   :type '(choice (const nil) regexp))
 190 (defcustom efs-super-dumb-unix-host-regexp nil
 191   "Regexp to match names of unix hosts with FTP servers that cannot do a PWD.
 192 It is also assumed that these hosts do not accept ls switches, whether
 193 or not this is actually true."
 194   :group 'efs-parameters
 195   :type '(choice (const nil) regexp))
 196 (defcustom efs-dos-host-regexp nil
 197   "Regexp to match names of hosts running DOS."
 198   :group 'efs-parameters
 199   :type '(choice (const nil) regexp))
 200 ;; In principal there is apollo unix support -- at least efs
 201 ;; should do the right thing. However, apollo ftp servers can be
 202 ;; very flakey, especially about accessing files by fullpaths.
 203 ;; Good luck.
 204 (defcustom efs-apollo-unix-host-regexp nil
 205   "Regexp to match names of apollo unix hosts running Apollo's Domain.
 206 For these hosts we don't short-circuit //'s immediately following
 207 \"/user@host:\""
 208   :group 'efs-parameters
 209   :type '(choice (const nil) regexp))
 210 (defcustom efs-mvs-host-regexp nil
 211   "Regexp to match names of hosts running MVS."
 212   :group 'efs-parameters
 213   :type '(choice (const nil) regexp))
 214 (defcustom efs-tops-20-host-regexp nil
 215   "Regexp to match names of hosts runninf TOPS-20."
 216   :group 'efs-parameters
 217   :type '(choice (const nil) regexp))
 218 (defcustom efs-mpe-host-regexp nil
 219   "Regexp to match hosts running the MPE operating system."
 220   :group 'efs-parameters
 221   :type '(choice (const nil) regexp))
 222 (defcustom efs-ka9q-host-regexp nil
 223   "Regexp to match hosts using the ka9q ftp server.
 224 These may actually be running one of DOS, LINUX, or unix."
 225   :group 'efs-parameters
 226   :type '(choice (const nil) regexp))
 227 (defcustom efs-dos-distinct-host-regexp nil
 228   "Regexp to match DOS hosts using the Distinct FTP server.
 229 These are not treated as DOS hosts with a special listing format, because
 230 the Distinct FTP server uses unix-style path syntax."
 231   :group 'efs-parameters
 232   :type '(choice (const nil) regexp))
 233 (defcustom efs-os2-host-regexp nil
 234   "Regexp to match names of hosts running OS/2."
 235   :group 'efs-parameters
 236   :type '(choice (const nil) regexp))
 237 (defcustom efs-vos-host-regexp nil
 238   "Regexp to match hosts running the VOS operating system."
 239   :group 'efs-parameters
 240   :type '(choice (const nil) regexp))
 241 (defcustom efs-hell-host-regexp nil
 242   "Regexp to match hosts using the hellsoft ftp server.
 243 These map be either DOS PC's or Macs."
 244   :group 'efs-parameters
 245   :type '(choice (const nil) regexp))
 246 ;; The way that we implement the hellsoft support, it probably won't
 247 ;; work with Macs. This could probably be fixed, if enough people scream.
 248 (defcustom efs-guardian-host-regexp nil
 249   "Regexp to match hosts running Tandem's guardian operating system."
 250   :group 'efs-parameters
 251   :type '(choice (const nil) regexp))
 252 ;; Note that ms-unix is really an FTP server running under DOS.
 253 ;; It's not a type of unix.
 254 (defcustom efs-ms-unix-host-regexp nil
 255   "Regexp to match hosts using the Microsoft FTP server in unix mode."
 256   :group 'efs-parameters
 257   :type '(choice (const nil) regexp))
 258 (defcustom efs-plan9-host-regexp nil
 259   "Regexp to match hosts running ATT's Plan 9 operating system."
 260   :group 'efs-parameters
 261   :type '(choice (const nil) regexp))
 262 (defcustom efs-cms-knet-host-regexp nil
 263   "Regexp to match hosts running the CMS KNET FTP server."
 264   :group 'efs-parameters
 265   :type '(choice (const nil) regexp))
 266 (defcustom efs-nos-ve-host-regexp nil
 267   "Regexp to match hosts running NOS/VE."
 268   :group 'efs-parameters
 269   :type '(choice (const nil) regexp))
 270 (defcustom efs-netware-host-regexp nil
 271   "Regexp to match hosts running Novell Netware."
 272   :group 'efs-parameters
 273   :type '(choice (const nil) regexp))
 274 (defcustom efs-dumb-apollo-unix-regexp nil
 275   "Regexp to match dumb hosts running Apollo's Domain.
 276 These are hosts which do not accept switches to ls over FTP."
 277   :group 'efs-parameters
 278   :type '(choice (const nil) regexp))
 279
 280 ;;; Further host types:
 281 ;;
 282 ;; unknown: This encompasses ka9q, dos-distinct, unix, sysV-unix, bsd-unix,
 283 ;;          next-unix, and dumb-unix.
 284
 285 (defconst efs-host-type-alist
 286   ;; When efs-add-host is called interactively, it will only allow
 287   ;; host types from this list.
 288   '((dumb-unix . efs-dumb-unix-host-regexp)
 289     (super-dumb-unix . efs-super-dumb-unix-host-regexp)
 290     (next-unix . efs-next-unix-host-regexp)
 291     (sysV-unix . efs-sysV-unix-host-regexp)
 292     (bsd-unix . efs-bsd-unix-host-regexp)
 293     (apollo-unix . efs-apollo-unix-host-regexp)
 294     (unix . efs-unix-host-regexp)
 295     (vms . efs-vms-host-regexp)
 296     (mts . efs-mts-host-regexp)
 297     (cms . efs-cms-host-regexp)
 298     (ti-explorer . efs-ti-explorer-host-regexp)
 299     (ti-twenex . efs-ti-twenex-host-regexp)
 300     (dos . efs-dos-host-regexp)
 301     (mvs . efs-mvs-host-regexp)
 302     (tops-20 . efs-tops-20-host-regexp)
 303     (mpe . efs-mpe-host-regexp)
 304     (ka9q . efs-ka9q-host-regexp)
 305     (dos-distinct . efs-dos-distinct-host-regexp)
 306     (os2 . efs-os2-host-regexp)
 307     (vos . efs-vos-host-regexp)
 308     (hell . efs-hell-host-regexp)
 309     (guardian . efs-guardian-host-regexp)
 310     (ms-unix . efs-ms-unix-host-regexp)
 311     (plan9 . efs-plan9-host-regexp)
 312     (cms-net . efs-cms-knet-host-regexp)
 313     (nos-ve . efs-nos-ve-host-regexp)
 314     (netware . efs-netware-host-regexp)
 315     (dumb-apollo-unix . efs-dumb-apollo-unix-regexp)))
 316
 317 ;; host type cache
 318 (defconst efs-host-cache nil)
 319 (defconst efs-host-type-cache nil)
 320
 321 ;; cache for efs-ftp-path.
 322 (defconst efs-ftp-path-arg "")
 323 (defconst efs-ftp-path-res nil)
 324
 325 ;;;; -------------------------------------------------------------
 326 ;;;; General macros.
 327 ;;;; -------------------------------------------------------------
 328
 329 (defmacro efs-save-match-data (&rest body)
 330   "Execute the BODY forms, restoring the global value of the match data.
 331 Before executing BODY, case-fold-search is locally bound to nil."
 332   ;; Because Emacs is buggy about let-binding buffer-local variables,
 333   ;; we have to do this in a slightly convoluted way.
 334   (let ((match-data-temp (make-symbol "match-data"))
 335         (buff-temp (make-symbol "buff"))
 336         (cfs-temp (make-symbol "cfs")))
 337     (list
 338      'let (list (list match-data-temp '(match-data))
 339                 (list buff-temp '(current-buffer))
 340                 (list cfs-temp 'case-fold-search))
 341      (list 'unwind-protect
 342            (cons 'progn
 343                  (cons
 344                   '(setq case-fold-search nil)
 345                   body))
 346            (list 'condition-case nil
 347                  (list 'save-excursion
 348                        (list 'set-buffer buff-temp)
 349                        (list 'setq 'case-fold-search cfs-temp))
 350                  '(error nil))
 351            (list 'store-match-data match-data-temp)))))
 352
 353 (put 'efs-save-match-data 'lisp-indent-hook 0)
 354 (put 'efs-save-match-data 'edebug-form-spec '(&rest form))
 355
 356 (defmacro efs-define-fun (fun args &rest body)
 357   "Like defun, but only defines a function if it has no previous definition."
 358   ;; There are easier ways to do this. This approach is used so that the
 359   ;; byte compiler won't complain about possibly undefined functions.
 360   (`
 361    (progn
 362      (put (quote (, fun)) 'efs-define-fun
 363           (and (fboundp (quote (, fun)))
 364                (symbol-function (quote (, fun)))))
 365      (defun (, fun) (, args) (,@ body))
 366      (if (and (get (quote (, fun)) 'efs-define-fun)
 367               (not (eq (car-safe (get (quote (, fun)) 'efs-define-fun))
 368                        (quote autoload))))
 369          (fset (quote (, fun)) (get (quote (, fun)) 'efs-define-fun)))
 370      (put (quote (, fun)) 'efs-define-fun nil)
 371      (quote (, fun)))))
 372
 373 (put 'efs-define-fun 'lisp-indent-hook 'defun)
 374
 375 (defmacro efs-quote-dollars (string)
 376   ;; Quote `$' as `$$' in STRING to get it past `substitute-in-file-name.'
 377   (`
 378    (let ((string (, string))
 379          (pos 0))
 380      (while (setq pos (string-match "\\$" string pos))
 381        (setq string (concat (substring string 0 pos)
 382                           "$";; precede by escape character (also a $)
 383                           (substring string pos))
 384              ;; add 2 instead 1 since another $ was inserted
 385              pos (+ 2 pos)))
 386      string)))
 387
 388 (defmacro efs-cont (implicit-args explicit-args &rest body)
 389   "Defines an efs continuation function.
 390 The IMPLICIT-ARGS are bound when the continuation function is called.
 391 The EXPLICIT-ARGS are bound when the continuation function is set."
 392   (let ((fun (list 'function
 393                    (cons 'lambda
 394                          (cons
 395                           (append implicit-args explicit-args)
 396                           body)))))
 397     (if explicit-args
 398         (cons 'list (cons fun explicit-args))
 399       fun)))
 400
 401 (put 'efs-cont 'lisp-indent-hook 2)
 402
 403 ;;;; ------------------------------------------------------------
 404 ;;;; Utility functions
 405 ;;;; ------------------------------------------------------------
 406
 407 (efs-define-fun efs-repaint-minibuffer ()
 408   ;; Set minibuf_message = 0, so that the contents of the minibuffer will show.
 409   ;; This is the Emacs V19 version of this function. For Emacs 18, it will
 410   ;; be redefined in a grotty way to accomplish the same thing.
 411   (message nil))
 412
 413 (defun efs-get-user (host)
 414   "Given a HOST, return the default USER."
 415   (efs-parse-netrc)
 416   ;; We cannot check for users case-insensitively on those systems
 417   ;; which are treat usernames case-insens., because we need to log in
 418   ;; first, before we know what type of system.
 419   (let ((user (efs-get-host-property host 'user)))
 420     (if (stringp user)
 421         user
 422       (prog1
 423           (setq user
 424                 (cond ((stringp efs-default-user)
 425                        ;; We have a default name.  Use it.
 426                        efs-default-user)
 427                       ((consp efs-default-user)
 428                        ;; Walk the list looking for a host-specific value.
 429                        (efs-save-match-data
 430                          (let ((alist efs-default-user)
 431                                (case-fold-search t)
 432                                result)
 433                            (while alist
 434                              (if (string-match (car (car alist)) host)
 435                                  (setq result (cdr (car alist))
 436                                        alist nil)
 437                                (setq alist (cdr alist))))
 438                            (cond
 439                             ((stringp result)
 440                              result)
 441                             (result
 442                              (let ((enable-recursive-minibuffers t))
 443                                (read-string (format "User for %s: " host)
 444                                             (user-login-name))))
 445                             (t
 446                              (user-login-name))))))
 447                       (efs-default-user
 448                        ;; Ask the user.
 449                        (let ((enable-recursive-minibuffers t))
 450                          (read-string (format "User for %s: " host)
 451                                       (user-login-name))))
 452                       ;; Default to the user's login name.
 453                       (t
 454                        (user-login-name))))
 455         (efs-set-user host user)))))
 456
 457 ;;;###autoload
 458 (defun efs-ftp-path (path)
 459   "Parse PATH according to efs-path-regexp.
 460 Returns a list (HOST USER PATH), or nil if PATH does not match the format."
 461   (or (string-equal path efs-ftp-path-arg)
 462       (setq efs-ftp-path-res
 463             (efs-save-match-data
 464               (and (string-match efs-path-regexp path)
 465                    (let ((host (substring path (match-beginning 2)
 466                                           (match-end 2)))
 467                          (user (and (match-beginning 1)
 468                                     (substring path (match-beginning 1)
 469                                                (1- (match-end 1)))))
 470                          (rpath (substring path (1+ (match-end 2)))))
 471                      (list (if (string-equal host "")
 472                                (setq host (system-name))
 473                              host)
 474                            (or user (efs-get-user host))
 475                            rpath))))
 476             ;; Set this last, in case efs-get-user calls this
 477             ;; function, which would modify an earlier setting.
 478             efs-ftp-path-arg path))
 479   efs-ftp-path-res)
 480
 481 (defun efs-chase-symlinks (file)
 482   ;; If FILE is a symlink, chase it until we get to a real file.
 483   ;; Unlike file truename, this function does not chase symlinks at
 484   ;; every level, only the bottom level. Therefore, it is not useful for
 485   ;; obtaining the truename of a file. It is useful for getting at file
 486   ;; attributes, with a lot less overhead than file truename.
 487
 488   ;; `file-symlink-p' just returns nil without running its handler(s)
 489   ;; and make-symbolic-link doesn't exist at all on systems that don't
 490   ;; support symlinks (ie S_IFLNK is undefined) such as MS Windows with
 491   ;; on some Emacsen and XEmacsen.
 492   (let ((target (if (efs-ftp-path file)
 493                     (efs-file-symlink-p file)
 494                   (file-symlink-p file))))
 495     (if target
 496         (efs-chase-symlinks
 497          (expand-file-name target (file-name-directory file)))
 498       file)))
 499
 500 ;; If efs-host-type is called with the optional user
 501 ;; argument, it will attempt to guess the host type by connecting
 502 ;; as user, if necessary.
 503
 504 (defun efs-host-type (host &optional user)
 505   "Return a symbol which represents the type of the HOST given.
 506 If the optional argument USER is given, attempts to guess the
 507 host-type by logging in as USER."
 508
 509   (and host
 510        (let ((host (downcase host))
 511              type)
 512          (cond
 513
 514           ((and efs-host-cache
 515                 (string-equal host efs-host-cache)
 516                 efs-host-type-cache))
 517
 518           ((setq type
 519                  (efs-get-host-property host 'host-type))
 520            (setq efs-host-cache host
 521                  efs-host-type-cache type))
 522
 523           ;; Trigger an ftp connection, in case we need to
 524           ;; guess at the host type.
 525           ((and user (efs-get-process host user)
 526                 (if (string-equal host efs-host-cache)
 527                     ;; logging in may update the cache
 528                     efs-host-type-cache
 529                   (and (setq type (efs-get-host-property host 'host-type))
 530                        (setq efs-host-cache host
 531                              efs-host-type-cache type)))))
 532
 533           ;; Try the regexps.
 534           ((setq type
 535                  (let ((alist efs-host-type-alist)
 536                        regexp type-pair)
 537                    (catch 'match
 538                      (efs-save-match-data
 539                        (let ((case-fold-search t))
 540                          (while alist
 541                            (progn
 542                              (and (setq type-pair (car alist)
 543                                         regexp (eval (cdr type-pair)))
 544                                   (string-match regexp host)
 545                                   (throw 'match (car type-pair)))
 546                              (setq alist (cdr alist)))))
 547                        nil))))
 548            (setq efs-host-cache host
 549                  efs-host-type-cache type))
 550           ;; Return 'unknown, but _don't_ cache it.
 551           (t 'unknown)))))
 552
 553 ;;;; -------------------------------------------------------------
 554 ;;;; Functions and macros for hashtables.
 555 ;;;; -------------------------------------------------------------
 556
 557 (defun efs-make-hashtable (&optional size)
 558   "Make an obarray suitable for use as a hashtable.
 559 SIZE, if supplied, should be a prime number."
 560   (make-vector (or size 31) 0))
 561
 562 (defun efs-map-hashtable (fun tbl &optional property)
 563   "Call FUNCTION on each key and value in HASHTABLE.
 564 If PROPERTY is non-nil, it is the property to be used as the second
 565 argument to FUNCTION. The default property is 'val"
 566   (let ((prop (or property 'val)))
 567     (mapatoms
 568      (function
 569       (lambda (sym)
 570         (funcall fun (symbol-name sym) (get sym prop))))
 571      tbl)))
 572
 573 (defmacro efs-make-hash-key (key)
 574   "Convert KEY into a suitable key for a hashtable. This returns a string."
 575   (` (let ((key (, key))) ; eval exactly once, in case evalling key moves the
 576                           ; point.
 577        (if (stringp key) key (prin1-to-string key)))))
 578
 579 ;;; Note, if you store entries in a hashtable case-sensitively, and then
 580 ;;; retrieve them with IGNORE-CASE=t, it is possible that there may be
 581 ;;; be more than one entry that could be retrieved. It is more or less random
 582 ;;; which one you'll get. The onus is on the programmer to be consistent.
 583 ;;; Suggestions to make this faster are gratefully accepted!
 584
 585 (defmacro efs-case-fold-intern-soft (name tbl)
 586   "Returns a symbol with case-insensitive name NAME in the obarray TBL.
 587 Case is considered insignificant in NAME. Note, if there is more than
 588 one possible match, it is hard to predicate which one you'll get."
 589   (`
 590    (let* ((completion-ignore-case t)
 591           (name (, name))
 592           (tbl (, tbl))
 593           (len (length (, name)))
 594           (newname (try-completion name tbl
 595                                    (function
 596                                     (lambda (sym)
 597                                       (= (length (symbol-name sym)) len))))))
 598      (and newname
 599           (if (eq newname t)
 600               (intern name tbl)
 601             (intern newname tbl))))))
 602
 603 (defmacro efs-hash-entry-exists-p (key tbl &optional ignore-case)
 604   "Return whether there is an association for KEY in TABLE.
 605 If optional IGNORE-CASE is non-nil, then ignore-case in the test."
 606   (` (let ((key (efs-make-hash-key (, key))))
 607        (if (, ignore-case)
 608            (efs-case-fold-intern-soft key (, tbl))
 609        (intern-soft key (, tbl))))))
 610
 611 (defmacro efs-get-hash-entry (key tbl &optional ignore-case)
 612   "Return the value associated with KEY in HASHTABLE.
 613 If the optional argument IGNORE-CASE is given, then case in the key is
 614 considered irrelevant."
 615   (` (let* ((key (efs-make-hash-key (, key)))
 616             (sym (if (, ignore-case)
 617                      (efs-case-fold-intern-soft key (, tbl))
 618                    (intern-soft key (, tbl)))))
 619        (and sym (get sym 'val)))))
 620
 621 (defmacro efs-put-hash-entry (key val tbl &optional ignore-case)
 622   "Record an association between KEY and VALUE in HASHTABLE.
 623 If the optional IGNORE-CASE argument is given, then check for an entry
 624 which is the same modulo case, and update it instead of adding a new entry."
 625   (` (let* ((key (efs-make-hash-key (, key)))
 626             (sym (if (, ignore-case)
 627                      (or (efs-case-fold-intern-soft key (, tbl))
 628                          (intern key (, tbl)))
 629                    (intern key (, tbl)))))
 630        (put sym 'val (, val)))))
 631
 632 (defun efs-del-hash-entry (key tbl &optional ignore-case)
 633   "Copy all symbols except KEY in HASHTABLE and return modified hashtable.
 634 If the optional argument CASE-FOLD is non-nil, then fold KEY to lower case."
 635   (let* ((len (length tbl))
 636          (new-tbl (efs-make-hashtable len))
 637          (i (1- len))
 638          (key (efs-make-hash-key key)))
 639     (if ignore-case (setq key (downcase key)))
 640     (efs-map-hashtable
 641      (if ignore-case
 642          (function
 643           (lambda (k v)
 644             (or (string-equal (downcase k) key)
 645                 ;; Don't need to specify ignore-case here, because
 646                 ;; we have already weeded out possible case-fold matches.
 647                 (efs-put-hash-entry k v new-tbl))))
 648        (function
 649         (lambda (k v)
 650           (or (string-equal k key)
 651               (efs-put-hash-entry k v new-tbl)))))
 652      tbl)
 653     (while (>= i 0)
 654       (aset tbl i (aref new-tbl i))
 655       (setq i (1- i)))
 656     ;; Return the result.
 657     tbl))
 658
 659 (defun efs-hash-table-keys (tbl &optional nosort)
 660   "Return a sorted of all the keys in the hashtable TBL, as strings.
 661 This list is sorted, unless the optional argument NOSORT is non-nil."
 662   (let ((result (all-completions "" tbl)))
 663     (if nosort
 664         result
 665       (sort result (function string-lessp)))))
 666
 667 ;;; hashtable variables
 668
 669 (defconst efs-host-hashtable (efs-make-hashtable)
 670   "Hash table holding data on hosts.")
 671
 672 (defconst efs-host-user-hashtable (efs-make-hashtable)
 673   "Hash table for holding data on host user pairs.")
 674
 675 (defconst efs-minidisk-hashtable (efs-make-hashtable)
 676   "Mapping between a host, user, minidisk triplet and a account password.")
 677
 678 ;;;; ------------------------------------------------------------
 679 ;;;; Host / User mapping
 680 ;;;; ------------------------------------------------------------
 681
 682 (defun efs-set-host-property (host property value)
 683   ;; For HOST, sets PROPERTY to VALUE.
 684   (put (intern (downcase host) efs-host-hashtable) property value))
 685
 686 (defun efs-get-host-property (host property)
 687   ;; For HOST, gets PROPERTY.
 688   (get (intern (downcase host) efs-host-hashtable) property))
 689
 690 (defun efs-set-host-user-property (host user property value)
 691   ;; For HOST and USER, sets PROPERTY to VALUE.
 692   (let* ((key (concat (downcase host) "/" user))
 693          (sym (and (memq (efs-host-type host) efs-case-insensitive-host-types)
 694                    (efs-case-fold-intern-soft key efs-host-user-hashtable))))
 695     (or sym (setq sym (intern key efs-host-user-hashtable)))
 696     (put sym property value)))
 697
 698 (defun efs-get-host-user-property (host user property)
 699   ;; For HOST and USER, gets PROPERTY.
 700   (let* ((key (concat (downcase host) "/" user))
 701          (sym (and (memq (efs-host-type host) efs-case-insensitive-host-types)
 702                    (efs-case-fold-intern-soft key efs-host-user-hashtable))))
 703     (or sym (setq sym (intern key efs-host-user-hashtable)))
 704     (get sym property)))
 705
 706 (defun efs-set-user (host user)
 707   "For a given HOST, set or change the default USER."
 708   (interactive "sHost: \nsUser: ")
 709   (efs-set-host-property host 'user user))
 710
 711 ;;;; ------------------------------------------------------------
 712 ;;;; Encryption
 713 ;;;; ------------------------------------------------------------
 714
 715 (defconst efs-passwd-seed nil)
 716 ;; seed used to encrypt the password cache.
 717
 718 (defun efs-get-passwd-seed ()
 719   ;; Returns a random number to use for encrypting passwords.
 720   (or efs-passwd-seed
 721       (setq efs-passwd-seed (+ 1 (random 255)))))
 722
 723 (defun efs-code-string (string)
 724   ;; Encode a string, using `efs-passwd-seed'. This is nil-potent,
 725   ;; meaning applying it twice decodes.
 726   (if (and (fboundp 'int-to-char) (fboundp 'char-to-int))
 727       (mapconcat
 728        (function
 729         (lambda (c)
 730           (char-to-string
 731            (int-to-char (logxor (efs-get-passwd-seed) (char-to-int c))))))
 732        string "")
 733     (mapconcat
 734      (function
 735       (lambda (c)
 736         (char-to-string (logxor (efs-get-passwd-seed) c))))
 737      string "")))
 738
 739 ;;; end of efs-cu.el