code.delx.au - gnu-emacs/blob - lisp/net/net-utils.el

   1 ;;; net-utils.el --- network functions
   2
   3 ;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004,
   4 ;;   2005, 2006, 2007, 2008 Free Software Foundation, Inc.
   5
   6 ;; Author:  Peter Breton <pbreton@cs.umb.edu>
   7 ;; Created: Sun Mar 16 1997
   8 ;; Keywords: network comm
   9
  10 ;; This file is part of GNU Emacs.
  11
  12 ;; GNU Emacs is free software: you can redistribute it and/or modify
  13 ;; it under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation, either version 3 of the License, or
  15 ;; (at your option) any later version.
  16
  17 ;; GNU Emacs is distributed in the hope that it will be useful,
  18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;; GNU General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  24
  25 ;;; Commentary:
  26
  27 ;;
  28 ;; There are three main areas of functionality:
  29 ;;
  30 ;; * Wrap common network utility programs (ping, traceroute, netstat,
  31 ;; nslookup, arp, route). Note that these wrappers are of the diagnostic
  32 ;; functions of these programs only.
  33 ;;
  34 ;; * Implement some very basic protocols in Emacs Lisp (finger and whois)
  35 ;;
  36 ;; * Support connections to HOST/PORT, generally for debugging and the like.
  37 ;; In other words, for doing much the same thing as "telnet HOST PORT", and
  38 ;; then typing commands.
  39 ;;
  40 ;; PATHS
  41 ;;
  42 ;; On some systems, some of these programs are not in normal user path,
  43 ;; but rather in /sbin, /usr/sbin, and so on.
  44
  45
  46 ;;; Code:
  47
  48 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  49 ;; Customization Variables
  50 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  51
  52 (defgroup net-utils nil
  53   "Network utility functions."
  54   :prefix "net-utils-"
  55   :group 'comm
  56   :version "20.3")
  57
  58 (defcustom net-utils-remove-ctl-m
  59   (member system-type (list 'windows-nt 'msdos))
  60   "If non-nil, remove control-Ms from output."
  61   :group 'net-utils
  62   :type  'boolean)
  63
  64 (defcustom traceroute-program
  65   (if (eq system-type 'windows-nt)
  66       "tracert"
  67     "traceroute")
  68   "Program to trace network hops to a destination."
  69   :group 'net-utils
  70   :type  'string)
  71
  72 (defcustom traceroute-program-options nil
  73   "Options for the traceroute program."
  74   :group 'net-utils
  75   :type  '(repeat string))
  76
  77 (defcustom ping-program "ping"
  78   "Program to send network test packets to a host."
  79   :group 'net-utils
  80   :type  'string)
  81
  82 ;; On GNU/Linux and Irix, the system's ping program seems to send packets
  83 ;; indefinitely unless told otherwise
  84 (defcustom ping-program-options
  85   (and (memq system-type (list 'linux 'gnu/linux 'irix))
  86        (list "-c" "4"))
  87   "Options for the ping program.
  88 These options can be used to limit how many ICMP packets are emitted."
  89   :group 'net-utils
  90   :type  '(repeat string))
  91
  92 (define-obsolete-variable-alias 'ipconfig-program 'ifconfig-program "22.2")
  93
  94 (defcustom ifconfig-program
  95   (if (eq system-type 'windows-nt)
  96       "ipconfig"
  97     "ifconfig")
  98   "Program to print network configuration information."
  99   :group 'net-utils
 100   :type  'string)
 101
 102 (defcustom ifconfig-program-options
 103   (list
 104    (if (eq system-type 'windows-nt)
 105        "/all" "-a"))
 106   "Options for the ifconfig program."
 107   :group 'net-utils
 108   :type  '(repeat string))
 109
 110 (defcustom iwconfig-program "iwconfig"
 111   "Program to print wireless network configuration information."
 112   :group 'net-utils
 113   :type 'string
 114   :version "23.1")
 115
 116 (define-obsolete-variable-alias 'ipconfig-program-options
 117   'ifconfig-program-options "22.2")
 118
 119 (defcustom iwconfig-program-options nil
 120  "Options for the iwconfig program."
 121  :group 'net-utils
 122  :type '(repeat string)
 123  :version "23.1")
 124
 125 (defcustom netstat-program "netstat"
 126   "Program to print network statistics."
 127   :group 'net-utils
 128   :type  'string)
 129
 130 (defcustom netstat-program-options
 131   (list "-a")
 132   "Options for the netstat program."
 133   :group 'net-utils
 134   :type  '(repeat string))
 135
 136 (defcustom arp-program "arp"
 137   "Program to print IP to address translation tables."
 138   :group 'net-utils
 139   :type  'string)
 140
 141 (defcustom arp-program-options
 142   (list "-a")
 143   "Options for the arp program."
 144   :group 'net-utils
 145   :type  '(repeat string))
 146
 147 (defcustom route-program
 148   (if (eq system-type 'windows-nt)
 149       "route"
 150     "netstat")
 151   "Program to print routing tables."
 152   :group 'net-utils
 153   :type  'string)
 154
 155 (defcustom route-program-options
 156   (if (eq system-type 'windows-nt)
 157       (list "print")
 158     (list "-r"))
 159   "Options for the route program."
 160   :group 'net-utils
 161   :type  '(repeat string))
 162
 163 (defcustom nslookup-program "nslookup"
 164   "Program to interactively query DNS information."
 165   :group 'net-utils
 166   :type  'string)
 167
 168 (defcustom nslookup-program-options nil
 169   "Options for the nslookup program."
 170   :group 'net-utils
 171   :type  '(repeat string))
 172
 173 (defcustom nslookup-prompt-regexp "^> "
 174   "Regexp to match the nslookup prompt.
 175
 176 This variable is only used if the variable
 177 `comint-use-prompt-regexp' is non-nil."
 178   :group 'net-utils
 179   :type  'regexp)
 180
 181 (defcustom dig-program "dig"
 182   "Program to query DNS information."
 183   :group 'net-utils
 184   :type  'string)
 185
 186 (defcustom ftp-program "ftp"
 187   "Program to run to do FTP transfers."
 188   :group 'net-utils
 189   :type  'string)
 190
 191 (defcustom ftp-program-options nil
 192   "Options for the ftp program."
 193   :group 'net-utils
 194   :type  '(repeat string))
 195
 196 (defcustom ftp-prompt-regexp "^ftp>"
 197   "Regexp which matches the FTP program's prompt.
 198
 199 This variable is only used if the variable
 200 `comint-use-prompt-regexp' is non-nil."
 201   :group 'net-utils
 202   :type  'regexp)
 203
 204 (defcustom smbclient-program "smbclient"
 205   "Smbclient program."
 206   :group 'net-utils
 207   :type  'string)
 208
 209 (defcustom smbclient-program-options nil
 210   "Options for the smbclient program."
 211   :group 'net-utils
 212   :type  '(repeat string))
 213
 214 (defcustom smbclient-prompt-regexp "^smb: \>"
 215   "Regexp which matches the smbclient program's prompt.
 216
 217 This variable is only used if the variable
 218 `comint-use-prompt-regexp' is non-nil."
 219   :group 'net-utils
 220   :type  'regexp)
 221
 222 (defcustom dns-lookup-program "host"
 223   "Program to interactively query DNS information."
 224   :group 'net-utils
 225   :type  'string)
 226
 227 (defcustom dns-lookup-program-options nil
 228   "Options for the dns-lookup program."
 229   :group 'net-utils
 230   :type  '(repeat string))
 231
 232 ;; Internal variables
 233 (defvar network-connection-service nil)
 234 (defvar network-connection-host    nil)
 235
 236 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 237 ;; Nslookup goodies
 238 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 239
 240 (defconst nslookup-font-lock-keywords
 241   (list
 242    (list "^[A-Za-z0-9 _]+:" 0 'font-lock-type-face)
 243    (list "\\<\\(SOA\\|NS\\|MX\\|A\\|CNAME\\)\\>"
 244          1 'font-lock-keyword-face)
 245    ;; Dotted quads
 246    (list
 247     (mapconcat 'identity
 248                (make-list 4 "[0-9]+")
 249                "\\.")
 250     0 'font-lock-variable-name-face)
 251    ;; Host names
 252    (list
 253     (let ((host-expression "[-A-Za-z0-9]+"))
 254       (concat
 255        (mapconcat 'identity
 256                   (make-list 2 host-expression)
 257                   "\\.")
 258        "\\(\\." host-expression "\\)*"))
 259     0 'font-lock-variable-name-face))
 260   "Expressions to font-lock for nslookup.")
 261
 262 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 263 ;; Utility functions
 264 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 265
 266 ;; Simplified versions of some at-point functions from ffap.el.
 267 ;; It's not worth loading all of ffap just for these.
 268 (defun net-utils-machine-at-point ()
 269   (let ((pt (point)))
 270     (buffer-substring-no-properties
 271      (save-excursion
 272        (skip-chars-backward "-a-zA-Z0-9.")
 273        (point))
 274      (save-excursion
 275        (skip-chars-forward "-a-zA-Z0-9.")
 276        (skip-chars-backward "." pt)
 277        (point)))))
 278
 279 (defun net-utils-url-at-point ()
 280   (let ((pt (point)))
 281     (buffer-substring-no-properties
 282      (save-excursion
 283        (skip-chars-backward "--:=&?$+@-Z_a-z~#,%")
 284        (skip-chars-forward "^A-Za-z0-9" pt)
 285        (point))
 286      (save-excursion
 287        (skip-chars-forward "--:=&?$+@-Z_a-z~#,%")
 288        (skip-chars-backward ":;.,!?" pt)
 289        (point)))))
 290
 291
 292 (defun net-utils-remove-ctrl-m-filter (process output-string)
 293   "Remove trailing control Ms."
 294   (let ((old-buffer (current-buffer))
 295         (filtered-string output-string))
 296     (unwind-protect
 297         (let ((moving))
 298           (set-buffer (process-buffer process))
 299           (setq moving (= (point) (process-mark process)))
 300
 301           (while (string-match "\r" filtered-string)
 302                (setq filtered-string
 303                      (replace-match "" nil nil filtered-string)))
 304
 305           (save-excursion
 306             ;; Insert the text, moving the process-marker.
 307             (goto-char (process-mark process))
 308             (insert filtered-string)
 309             (set-marker (process-mark process) (point)))
 310           (if moving (goto-char (process-mark process))))
 311       (set-buffer old-buffer))))
 312
 313 (defun net-utils-run-program (name header program args)
 314   "Run a network information program."
 315   (let ((buf (get-buffer-create (concat "*" name "*"))))
 316     (set-buffer buf)
 317     (erase-buffer)
 318     (insert header "\n")
 319     (set-process-filter
 320      (apply 'start-process name buf program args)
 321      'net-utils-remove-ctrl-m-filter)
 322     (display-buffer buf)
 323     buf))
 324
 325 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 326 ;; Wrappers for external network programs
 327 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 328
 329 ;;;###autoload
 330 (defun traceroute (target)
 331   "Run traceroute program for TARGET."
 332   (interactive "sTarget: ")
 333   (let ((options
 334          (if traceroute-program-options
 335              (append traceroute-program-options (list target))
 336            (list target))))
 337     (net-utils-run-program
 338      (concat "Traceroute" " " target)
 339      (concat "** Traceroute ** " traceroute-program " ** " target)
 340      traceroute-program
 341      options)))
 342
 343 ;;;###autoload
 344 (defun ping (host)
 345   "Ping HOST.
 346 If your system's ping continues until interrupted, you can try setting
 347 `ping-program-options'."
 348   (interactive
 349    (list (read-from-minibuffer "Ping host: " (net-utils-machine-at-point))))
 350   (let ((options
 351          (if ping-program-options
 352              (append ping-program-options (list host))
 353            (list host))))
 354     (net-utils-run-program
 355      (concat "Ping" " " host)
 356      (concat "** Ping ** " ping-program " ** " host)
 357      ping-program
 358      options)))
 359
 360 ;;;###autoload
 361 (defun ifconfig ()
 362   "Run ifconfig program."
 363   (interactive)
 364   (net-utils-run-program
 365    "Ifconfig"
 366    (concat "** Ifconfig ** " ifconfig-program " ** ")
 367    ifconfig-program
 368    ifconfig-program-options))
 369
 370 ;; Windows uses this name.
 371 ;;;###autoload
 372 (defalias 'ipconfig 'ifconfig)
 373
 374 ;;;###autoload
 375 (defun iwconfig ()
 376   "Run iwconfig program."
 377   (interactive)
 378   (net-utils-run-program
 379    "Iwconfig"
 380    (concat "** Iwconfig ** " iwconfig-program " ** ")
 381    iwconfig-program
 382    iwconfig-program-options))
 383
 384 ;;;###autoload
 385 (defun netstat ()
 386   "Run netstat program."
 387   (interactive)
 388   (net-utils-run-program
 389    "Netstat"
 390    (concat "** Netstat ** " netstat-program " ** ")
 391    netstat-program
 392    netstat-program-options))
 393
 394 ;;;###autoload
 395 (defun arp ()
 396   "Run arp program."
 397   (interactive)
 398   (net-utils-run-program
 399    "Arp"
 400    (concat "** Arp ** " arp-program " ** ")
 401    arp-program
 402    arp-program-options))
 403
 404 ;;;###autoload
 405 (defun route ()
 406   "Run route program."
 407   (interactive)
 408   (net-utils-run-program
 409    "Route"
 410    (concat "** Route ** " route-program " ** ")
 411    route-program
 412    route-program-options))
 413
 414 ;; FIXME -- Needs to be a process filter
 415 ;; (defun netstat-with-filter (filter)
 416 ;;   "Run netstat program."
 417 ;;   (interactive "sFilter: ")
 418 ;;   (netstat)
 419 ;;   (set-buffer (get-buffer "*Netstat*"))
 420 ;;   (goto-char (point-min))
 421 ;;   (delete-matching-lines filter))
 422
 423 ;;;###autoload
 424 (defun nslookup-host (host)
 425   "Lookup the DNS information for HOST."
 426   (interactive
 427    (list (read-from-minibuffer "Lookup host: " (net-utils-machine-at-point))))
 428   (let ((options
 429          (if nslookup-program-options
 430              (append nslookup-program-options (list host))
 431            (list host))))
 432     (net-utils-run-program
 433      "Nslookup"
 434      (concat "** "
 435       (mapconcat 'identity
 436                 (list "Nslookup" host nslookup-program)
 437                 " ** "))
 438      nslookup-program
 439      options)))
 440
 441 ;;;###autoload
 442 (defun nslookup ()
 443   "Run nslookup program."
 444   (interactive)
 445   (comint-run nslookup-program)
 446   (nslookup-mode))
 447
 448 (defvar comint-prompt-regexp)
 449 (defvar comint-input-autoexpand)
 450
 451 (autoload 'comint-mode "comint" nil t)
 452
 453 ;; Using a derived mode gives us keymaps, hooks, etc.
 454 (define-derived-mode nslookup-mode comint-mode "Nslookup"
 455   "Major mode for interacting with the nslookup program."
 456   (set
 457    (make-local-variable 'font-lock-defaults)
 458    '((nslookup-font-lock-keywords)))
 459   (setq comint-prompt-regexp nslookup-prompt-regexp)
 460   (setq comint-input-autoexpand t))
 461
 462 (define-key nslookup-mode-map "\t" 'comint-dynamic-complete)
 463
 464 ;;;###autoload
 465 (defun dns-lookup-host (host)
 466   "Lookup the DNS information for HOST (name or IP address)."
 467   (interactive
 468    (list (read-from-minibuffer "Lookup host: " (net-utils-machine-at-point))))
 469   (let ((options
 470          (if dns-lookup-program-options
 471              (append dns-lookup-program-options (list host))
 472            (list host))))
 473     (net-utils-run-program
 474      (concat "DNS Lookup [" host "]")
 475      (concat "** "
 476       (mapconcat 'identity
 477                 (list "DNS Lookup" host dns-lookup-program)
 478                 " ** "))
 479      dns-lookup-program
 480      options)))
 481
 482 (autoload 'ffap-string-at-point "ffap")
 483
 484 ;;;###autoload
 485 (defun run-dig (host)
 486   "Run dig program."
 487   (interactive
 488    (list
 489     (read-from-minibuffer "Lookup host: "
 490                           (or (ffap-string-at-point 'machine) ""))))
 491   (net-utils-run-program
 492    "Dig"
 493    (concat "** "
 494            (mapconcat 'identity
 495                       (list "Dig" host dig-program)
 496                       " ** "))
 497    dig-program
 498    (list host)))
 499
 500 (autoload 'comint-exec "comint")
 501
 502 ;; This is a lot less than ange-ftp, but much simpler.
 503 ;;;###autoload
 504 (defun ftp (host)
 505   "Run ftp program."
 506   (interactive
 507    (list
 508     (read-from-minibuffer
 509      "Ftp to Host: " (net-utils-machine-at-point))))
 510   (let ((buf (get-buffer-create (concat "*ftp [" host "]*"))))
 511     (set-buffer buf)
 512     (ftp-mode)
 513     (comint-exec buf (concat "ftp-" host) ftp-program nil
 514                  (if ftp-program-options
 515                      (append (list host) ftp-program-options)
 516                    (list host)))
 517     (pop-to-buffer buf)))
 518
 519 (define-derived-mode ftp-mode comint-mode "FTP"
 520   "Major mode for interacting with the ftp program."
 521   (setq comint-prompt-regexp ftp-prompt-regexp)
 522   (setq comint-input-autoexpand t)
 523   ;; Only add the password-prompting hook if it's not already in the
 524   ;; global hook list.  This stands a small chance of losing, if it's
 525   ;; later removed from the global list (very small, since any
 526   ;; password prompts will probably immediately follow the initial
 527   ;; connection), but it's better than getting prompted twice for the
 528   ;; same password.
 529   (unless (memq 'comint-watch-for-password-prompt
 530                 (default-value 'comint-output-filter-functions))
 531     (add-hook 'comint-output-filter-functions 'comint-watch-for-password-prompt
 532               nil t)))
 533
 534 ;; Occasionally useful
 535 (define-key ftp-mode-map "\t" 'comint-dynamic-complete)
 536
 537 (defun smbclient (host service)
 538   "Connect to SERVICE on HOST via SMB."
 539   (interactive
 540    (list
 541     (read-from-minibuffer
 542      "Connect to Host: " (net-utils-machine-at-point))
 543     (read-from-minibuffer "SMB Service: ")))
 544   (let* ((name (format "smbclient [%s\\%s]" host service))
 545          (buf (get-buffer-create (concat "*" name "*")))
 546          (service-name (concat "\\\\" host "\\" service)))
 547     (set-buffer buf)
 548     (smbclient-mode)
 549     (comint-exec buf name smbclient-program nil
 550                  (if smbclient-program-options
 551                      (append (list service-name) smbclient-program-options)
 552                    (list service-name)))
 553     (pop-to-buffer buf)))
 554
 555 (defun smbclient-list-shares (host)
 556   "List services on HOST."
 557   (interactive
 558    (list
 559     (read-from-minibuffer
 560      "Connect to Host: " (net-utils-machine-at-point))))
 561   (let ((buf (get-buffer-create (format "*SMB Shares on %s*" host))))
 562     (set-buffer buf)
 563     (smbclient-mode)
 564     (comint-exec buf "smbclient-list-shares"
 565                  smbclient-program nil (list "-L" host))
 566     (pop-to-buffer buf)))
 567
 568 (define-derived-mode smbclient-mode comint-mode "smbclient"
 569   "Major mode for interacting with the smbclient program."
 570   (setq comint-prompt-regexp smbclient-prompt-regexp)
 571   (setq comint-input-autoexpand t)
 572   ;; Only add the password-prompting hook if it's not already in the
 573   ;; global hook list.  This stands a small chance of losing, if it's
 574   ;; later removed from the global list (very small, since any
 575   ;; password prompts will probably immediately follow the initial
 576   ;; connection), but it's better than getting prompted twice for the
 577   ;; same password.
 578   (unless (memq 'comint-watch-for-password-prompt
 579                 (default-value 'comint-output-filter-functions))
 580     (add-hook 'comint-output-filter-functions 'comint-watch-for-password-prompt
 581               nil t)))
 582
 583
 584 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 585 ;; Network Connections
 586 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 587
 588 ;; Full list is available at:
 589 ;; http://www.iana.org/assignments/port-numbers
 590 (defvar network-connection-service-alist
 591   (list
 592     (cons 'echo          7)
 593     (cons 'active-users 11)
 594     (cons 'daytime      13)
 595     (cons 'chargen      19)
 596     (cons 'ftp          21)
 597     (cons 'telnet       23)
 598     (cons 'smtp         25)
 599     (cons 'time         37)
 600     (cons 'whois        43)
 601     (cons 'gopher       70)
 602     (cons 'finger       79)
 603     (cons 'www          80)
 604     (cons 'pop2         109)
 605     (cons 'pop3         110)
 606     (cons 'sun-rpc      111)
 607     (cons 'nntp         119)
 608     (cons 'ntp          123)
 609     (cons 'netbios-name 137)
 610     (cons 'netbios-data 139)
 611     (cons 'irc          194)
 612     (cons 'https        443)
 613     (cons 'rlogin       513))
 614   "Alist of services and associated TCP port numbers.
 615 This list is not complete.")
 616
 617 ;; Workhorse routine
 618 (defun run-network-program (process-name host port &optional initial-string)
 619   (let ((tcp-connection)
 620         (buf))
 621     (setq buf (get-buffer-create (concat "*" process-name "*")))
 622     (set-buffer buf)
 623     (or
 624      (setq tcp-connection
 625            (open-network-stream process-name buf host port))
 626      (error "Could not open connection to %s" host))
 627     (erase-buffer)
 628     (set-marker (process-mark tcp-connection) (point-min))
 629     (set-process-filter tcp-connection 'net-utils-remove-ctrl-m-filter)
 630     (and initial-string
 631          (process-send-string tcp-connection
 632                               (concat initial-string "\r\n")))
 633     (display-buffer buf)))
 634
 635 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 636 ;; Simple protocols
 637 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 638
 639 (defcustom finger-X.500-host-regexps nil
 640   "A list of regular expressions matching host names.
 641 If a host name passed to `finger' matches one of these regular
 642 expressions, it is assumed to be a host that doesn't accept
 643 queries of the form USER@HOST, and wants a query containing USER only."
 644   :group 'net-utils
 645   :type '(repeat regexp)
 646   :version "21.1")
 647
 648 ;; Finger protocol
 649 ;;;###autoload
 650 (defun finger (user host)
 651   "Finger USER on HOST."
 652   ;; One of those great interactive statements that's actually
 653   ;; longer than the function call! The idea is that if the user
 654   ;; uses a string like "pbreton@cs.umb.edu", we won't ask for the
 655   ;; host name. If we don't see an "@", we'll prompt for the host.
 656   (interactive
 657     (let* ((answer (read-from-minibuffer "Finger User: "
 658                                          (net-utils-url-at-point)))
 659            (index  (string-match (regexp-quote "@") answer)))
 660       (if index
 661           (list (substring answer 0 index)
 662                 (substring answer (1+ index)))
 663         (list answer
 664               (read-from-minibuffer "At Host: "
 665                                     (net-utils-machine-at-point))))))
 666   (let* ((user-and-host (concat user "@" host))
 667          (process-name (concat "Finger [" user-and-host "]"))
 668          (regexps finger-X.500-host-regexps)
 669          found)
 670     (and regexps
 671          (while (not (string-match (car regexps) host))
 672            (setq regexps (cdr regexps)))
 673          (when regexps
 674            (setq user-and-host user)))
 675     (run-network-program
 676      process-name
 677      host
 678      (cdr (assoc 'finger network-connection-service-alist))
 679      user-and-host)))
 680
 681 (defcustom whois-server-name "rs.internic.net"
 682   "Default host name for the whois service."
 683   :group 'net-utils
 684   :type  'string)
 685
 686 (defcustom whois-server-list
 687   '(("whois.arin.net")     ; Networks, ASN's, and related POC's (numbers)
 688     ("rs.internic.net")  ; domain related info
 689     ("whois.publicinterestregistry.net")
 690     ("whois.abuse.net")
 691     ("whois.apnic.net")
 692     ("nic.ddn.mil")
 693     ("whois.nic.mil")
 694     ("whois.nic.gov")
 695     ("whois.ripe.net"))
 696   "A list of whois servers that can be queried."
 697   :group 'net-utils
 698   :type '(repeat (list string)))
 699
 700 ;; FIXME: modern whois clients include a much better tld <-> whois server
 701 ;; list, Emacs should probably avoid specifying the server as the client
 702 ;; will DTRT anyway... -rfr
 703 (defcustom whois-server-tld
 704   '(("rs.internic.net" . "com")
 705     ("whois.publicinterestregistry.net" . "org")
 706     ("whois.ripe.net" . "be")
 707     ("whois.ripe.net" . "de")
 708     ("whois.ripe.net" . "dk")
 709     ("whois.ripe.net" . "it")
 710     ("whois.ripe.net" . "fi")
 711     ("whois.ripe.net" . "fr")
 712     ("whois.ripe.net" . "uk")
 713     ("whois.apnic.net" . "au")
 714     ("whois.apnic.net" . "ch")
 715     ("whois.apnic.net" . "hk")
 716     ("whois.apnic.net" . "jp")
 717     ("whois.nic.gov" . "gov")
 718     ("whois.nic.mil" . "mil"))
 719   "Alist to map top level domains to whois servers."
 720   :group 'net-utils
 721   :type '(repeat (cons string string)))
 722
 723 (defcustom whois-guess-server t
 724   "If non-nil then whois will try to deduce the appropriate whois
 725 server from the query.  If the query doesn't look like a domain or hostname
 726 then the server named by `whois-server-name' is used."
 727   :group 'net-utils
 728   :type 'boolean)
 729
 730 (defun whois-get-tld (host)
 731   "Return the top level domain of `host', or nil if it isn't a domain name."
 732   (let ((i (1- (length host)))
 733         (max-len (- (length host) 5)))
 734     (while (not (or (= i max-len) (char-equal (aref host i) ?.)))
 735       (setq i (1- i)))
 736     (if (= i max-len)
 737         nil
 738       (substring host (1+ i)))))
 739
 740 ;; Whois protocol
 741 ;;;###autoload
 742 (defun whois (arg search-string)
 743   "Send SEARCH-STRING to server defined by the `whois-server-name' variable.
 744 If `whois-guess-server' is non-nil, then try to deduce the correct server
 745 from SEARCH-STRING.  With argument, prompt for whois server."
 746   (interactive "P\nsWhois: ")
 747   (let* ((whois-apropos-host (if whois-guess-server
 748                                  (rassoc (whois-get-tld search-string)
 749                                          whois-server-tld)
 750                                nil))
 751          (server-name (if whois-apropos-host
 752                           (car whois-apropos-host)
 753                         whois-server-name))
 754          (host
 755           (if arg
 756               (completing-read "Whois server name: "
 757                                whois-server-list nil nil "whois.")
 758             server-name)))
 759     (run-network-program
 760      "Whois"
 761      host
 762      (cdr (assoc 'whois network-connection-service-alist))
 763      search-string)))
 764
 765 (defcustom whois-reverse-lookup-server "whois.arin.net"
 766   "Server which provides inverse DNS mapping."
 767   :group 'net-utils
 768   :type  'string)
 769
 770 ;;;###autoload
 771 (defun whois-reverse-lookup ()
 772   (interactive)
 773   (let ((whois-server-name whois-reverse-lookup-server))
 774     (call-interactively 'whois)))
 775
 776 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 777 ;;; General Network connection
 778 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 779
 780 ;; Using a derived mode gives us keymaps, hooks, etc.
 781 (define-derived-mode
 782   network-connection-mode comint-mode "Network-Connection"
 783   "Major mode for interacting with the network-connection program.")
 784
 785 (defun network-connection-mode-setup (host service)
 786   (make-local-variable 'network-connection-host)
 787   (setq network-connection-host host)
 788   (make-local-variable 'network-connection-service)
 789   (setq network-connection-service service))
 790
 791 ;;;###autoload
 792 (defun network-connection-to-service (host service)
 793   "Open a network connection to SERVICE on HOST."
 794   (interactive
 795    (list
 796     (read-from-minibuffer "Host: " (net-utils-machine-at-point))
 797     (completing-read "Service: "
 798                      (mapcar
 799                       (function
 800                        (lambda (elt)
 801                          (list (symbol-name (car elt)))))
 802                       network-connection-service-alist))))
 803   (network-connection
 804    host
 805    (cdr (assoc (intern service) network-connection-service-alist))))
 806
 807 ;;;###autoload
 808 (defun network-connection (host port)
 809   "Open a network connection to HOST on PORT."
 810   (interactive "sHost: \nnPort: ")
 811   (network-service-connection host (number-to-string port)))
 812
 813 (defun network-service-connection (host service)
 814   "Open a network connection to SERVICE on HOST."
 815   (let* ((process-name (concat "Network Connection [" host " " service "]"))
 816          (portnum (string-to-number service))
 817          (buf (get-buffer-create (concat "*" process-name "*"))))
 818     (or (zerop portnum) (setq service portnum))
 819     (make-comint
 820      process-name
 821      (cons host service))
 822     (set-buffer buf)
 823     (network-connection-mode)
 824     (network-connection-mode-setup host service)
 825     (pop-to-buffer buf)))
 826
 827 (defvar comint-input-ring)
 828
 829 (defun network-connection-reconnect  ()
 830   "Reconnect a network connection, preserving the old input ring."
 831   (interactive)
 832   (let ((proc (get-buffer-process (current-buffer)))
 833         (old-comint-input-ring comint-input-ring)
 834         (host network-connection-host)
 835         (service network-connection-service))
 836     (if (not (or (not proc)
 837                  (eq (process-status proc) 'closed)))
 838         (message "Still connected")
 839       (goto-char (point-max))
 840       (insert (format "Reopening connection to %s\n" host))
 841       (network-connection host
 842                           (if (numberp service)
 843                               service
 844                             (cdr (assoc service network-connection-service-alist))))
 845       (and old-comint-input-ring
 846            (setq comint-input-ring old-comint-input-ring)))))
 847
 848 (provide 'net-utils)
 849
 850 ;; arch-tag: 97119e91-9edb-4376-838b-bf7058fa1314
 851 ;;; net-utils.el ends here