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

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