# HG changeset patch # User Dan Nicolaescu # Date 898481021 0 # Node ID 7947a4ea28a8bbd69e77cbfb891fc879d68ef0f2 # Parent e4bcb7cb0038de2e2d72ebdc5e9df1a464dc02f6 Initial revision diff -r e4bcb7cb0038 -r 7947a4ea28a8 lisp/emacs-lisp/sregex.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/emacs-lisp/sregex.el Mon Jun 22 02:03:41 1998 +0000 @@ -0,0 +1,965 @@ +;;; sregex.el --- symbolic regular expressions + +;; Copyright (C) 1997, 1998 Free Software Foundation, Inc. + +;; Author: Bob Glickstein +;; Maintainer: Bob Glickstein + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; This package allows you to write regular expressions using a +;; totally new, Lisp-like syntax. + +;; A "symbolic regular expression" (sregex for short) is a Lisp form +;; that, when evaluated, produces the string form of the specified +;; regular expression. Here's a simple example: + +;; (sregexq (or "Bob" "Robert")) => "Bob\\|Robert" + +;; As you can see, an sregex is specified by placing one or more +;; special clauses in a call to `sregexq'. The clause in this case is +;; the `or' of two strings (not to be confused with the Lisp function +;; `or'). The list of allowable clauses appears below. + +;; With sregex, it is never necessary to "escape" magic characters +;; that are meant to be taken literally; that happens automatically. +;; For example: + +;; (sregexq "M*A*S*H") => "M\\*A\\*S\\*H" + +;; It is also unnecessary to "group" parts of the expression together +;; to overcome operator precedence; that also happens automatically. +;; For example: + +;; (sregexq (opt (or "Bob" "Robert"))) => "\\(Bob\\|Robert\\)?" + +;; It *is* possible to group parts of the expression in order to refer +;; to them with numbered backreferences: + +;; (sregexq (group (or "Go" "Run")) +;; ", Spot, " +;; (backref 1)) => "\\(Go\\|Run\\), Spot, \\1" + +;; If `sregexq' needs to introduce its own grouping parentheses, it +;; will automatically renumber your backreferences: + +;; (sregexq (opt "resent-") +;; (group (or "to" "cc" "bcc")) +;; ": " +;; (backref 1)) => "\\(resent-\\)?\\(to\\|cc\\|bcc\\): \\2" + +;; `sregexq' is a macro. Each time it is used, it constructs a simple +;; Lisp expression that then invokes a moderately complex engine to +;; interpret the sregex and render the string form. Because of this, +;; I don't recommend sprinkling calls to `sregexq' throughout your +;; code, the way one normally does with string regexes (which are +;; cheap to evaluate). Instead, it's wiser to precompute the regexes +;; you need wherever possible instead of repeatedly constructing the +;; same ones over and over. Example: + +;; (let ((field-regex (sregexq (opt "resent-") +;; (or "to" "cc" "bcc")))) +;; ... +;; (while ... +;; ... +;; (re-search-forward field-regex ...) +;; ...)) + +;; The arguments to `sregexq' are automatically quoted, but the +;; flipside of this is that it is not straightforward to include +;; computed (i.e., non-constant) values in `sregexq' expressions. So +;; `sregex' is a function that is like `sregexq' but which does not +;; automatically quote its values. Literal sregex clauses must be +;; explicitly quoted like so: + +;; (sregex '(or "Bob" "Robert")) => "Bob\\|Robert" + +;; but computed clauses can be included easily, allowing for the reuse +;; of common clauses: + +;; (let ((dotstar '(0+ any)) +;; (whitespace '(1+ (syntax ?-))) +;; (digits '(1+ (char (?0 . ?9))))) +;; (sregex 'bol dotstar ":" whitespace digits)) => "^.*:\\s-+[0-9]+" + +;; This package also provides sregex-specific versions of the Emacs +;; functions `replace-match', `match-string', +;; `match-string-no-properties', `match-beginning', `match-end', and +;; `match-data'. In each case, the sregex version's name begins with +;; `sregex-' and takes one additional optional parameter, an sregex +;; "info" object. Each of these functions is concerned with numbered +;; submatches. Since sregex may renumber submatches, alternate +;; versions of these functions are needed that know how to adjust the +;; supplied number. + +;; The sregex info object for the most recently evaluated sregex can +;; be obtained with `sregex-info'; so if you precompute your sregexes +;; and you plan to use `replace-match' or one of the others with it, +;; you need to record the info object for later use: + +;; (let* ((regex (sregexq (opt "resent-") +;; (group (or "to" "cc" "bcc")) +;; ":")) +;; (regex-info (sregex-info))) +;; ... +;; (if (re-search-forward regex ...) +;; (let ((which (sregex-match-string 1 nil regex-info))) +;; ...))) + +;; In this example, `regex' is "\\(resent-\\)?\\(to\\|cc\\|bcc\\):", +;; so the call to (sregex-match-string 1 ...) is automatically turned +;; into a call to (match-string 2 ...). + +;; If the sregex info argument to `sregex-replace-match', +;; `sregex-match-string', `sregex-match-string-no-properties', +;; `sregex-match-beginning', `sregex-match-end', or +;; `sregex-match-data' is omitted, the current value of (sregex-info) +;; is used. + +;; You can do your own sregex submatch renumbering with +;; `sregex-backref-num'. + +;; Finally, `sregex-save-match-data' is like `save-match-data' but +;; also saves and restores the information maintained by +;; `sregex-info'. + +;; To use this package in a Lisp program, simply (require 'sregex). + +;; Here are the clauses allowed in an `sregex' or `sregexq' +;; expression: + +;; - a string +;; This stands for the literal string. If it contains +;; metacharacters, they will be escaped in the resulting regex +;; (using `regexp-quote'). + +;; - the symbol `any' +;; This stands for ".", a regex matching any character except +;; newline. + +;; - the symbol `bol' +;; Stands for "^", matching the empty string at the beginning of a line + +;; - the symbol `eol' +;; Stands for "$", matching the empty string at the end of a line + +;; - (group CLAUSE ...) +;; Groups the given CLAUSEs using "\\(" and "\\)". + +;; - (sequence CLAUSE ...) + +;; Groups the given CLAUSEs; may or may not use "\\(" and "\\)". +;; Clauses groups by `sequence' do not count for purposes of +;; numbering backreferences. Use `sequence' in situations like +;; this: + +;; (sregexq (or "dog" "cat" +;; (sequence (opt "sea ") "monkey"))) +;; => "dog\\|cat\\|\\(sea \\)?monkey" + +;; where a single `or' alternate needs to contain multiple +;; subclauses. + +;; - (backref N) +;; Matches the same string previously matched by the Nth "group" in +;; the same sregex. N is a positive integer. In the resulting +;; regex, N may be adjusted to account for automatically introduced +;; groups. + +;; - (or CLAUSE ...) +;; Matches any one of the CLAUSEs by separating them with "\\|". + +;; - (0+ CLAUSE ...) +;; Concatenates the given CLAUSEs and matches zero or more +;; occurrences by appending "*". + +;; - (1+ CLAUSE ...) +;; Concatenates the given CLAUSEs and matches one or more +;; occurrences by appending "+". + +;; - (opt CLAUSE ...) +;; Concatenates the given CLAUSEs and matches zero or one occurrence +;; by appending "?". + +;; - (repeat MIN MAX CLAUSE ...) +;; Concatenates the given CLAUSEs and constructs a regex matching at +;; least MIN occurrences and at most MAX occurrences. MIN must be a +;; non-negative integer. MAX must be a non-negative integer greater +;; than or equal to MIN; or MAX can be nil to mean "infinity." + +;; - (char CHAR-CLAUSE ...) +;; Creates a "character class" matching one character from the given +;; set. See below for how to construct a CHAR-CLAUSE. + +;; - (not-char CHAR-CLAUSE ...) +;; Creates a "character class" matching any one character not in the +;; given set. See below for how to construct a CHAR-CLAUSE. + +;; - the symbol `bot' +;; Stands for "\\`", matching the empty string at the beginning of +;; text (beginning of a string or of a buffer). + +;; - the symbol `eot' +;; Stands for "\\'", matching the empty string at the end of text. + +;; - the symbol `point' +;; Stands for "\\=", matching the empty string at point. + +;; - the symbol `word-boundary' +;; Stands for "\\b", matching the empty string at the beginning or +;; end of a word. + +;; - the symbol `not-word-boundary' +;; Stands for "\\B", matching the empty string not at the beginning +;; or end of a word. + +;; - the symbol `bow' +;; Stands for "\\<", matching the empty string at the beginning of a +;; word. + +;; - the symbol `eow' +;; Stands for "\\>", matching the empty string at the end of a word. + +;; - the symbol `wordchar' +;; Stands for the regex "\\w", matching a word-constituent character +;; (as determined by the current syntax table) + +;; - the symbol `not-wordchar' +;; Stands for the regex "\\W", matching a non-word-constituent +;; character. + +;; - (syntax CODE) +;; Stands for the regex "\\sCODE", where CODE is a syntax table code +;; (a single character). Matches any character with the requested +;; syntax. + +;; - (not-syntax CODE) +;; Stands for the regex "\\SCODE", where CODE is a syntax table code +;; (a single character). Matches any character without the +;; requested syntax. + +;; - (regex REGEX) +;; This is a "trapdoor" for including ordinary regular expression +;; strings in the result. Some regular expressions are clearer when +;; written the old way: "[a-z]" vs. (sregexq (char (?a . ?z))), for +;; instance. However, see the note under "Bugs," below. + +;; Each CHAR-CLAUSE that is passed to (char ...) and (not-char ...) +;; has one of the following forms: + +;; - a character +;; Adds that character to the set. + +;; - a string +;; Adds all the characters in the string to the set. + +;; - A pair (MIN . MAX) +;; Where MIN and MAX are characters, adds the range of characters +;; from MIN through MAX to the set. + +;;; To do: + +;; Make (sregexq (or "a" (sequence "b" "c"))) return "a\\|bc" instead +;; of "a\\|\\(bc\\)" + +;; An earlier version of this package could optionally translate the +;; symbolic regex into other languages' syntaxes, e.g. Perl. For +;; instance, with Perl syntax selected, (sregexq (or "ab" "cd")) would +;; yield "ab|cd" instead of "ab\\|cd". It might be useful to restore +;; such a facility. + +;;; Bugs: + +;; The (regex REGEX) form can confuse the code that distinguishes +;; introduced groups from user-specified groups. Try to avoid using +;; grouping within a `regex' form. Failing that, try to avoid using +;; backrefs if you're using `regex'. + +;;; Code: + +(defsubst sregex--value-unitp (val) (nth 0 val)) +(defsubst sregex--value-groups (val) (nth 1 val)) +(defsubst sregex--value-tree (val) (nth 2 val)) + +(defun sregex--make-value (unitp groups tree) + (list unitp groups tree)) + +(defvar sregex--current-sregex nil + "Global state for `sregex-info'.") + +(defun sregex-info () + "Return extra information about the latest call to `sregex'. +This extra information is needed in order to adjust user-requested +backreference numbers to numbers suitable for the generated regexp. +See e.g. `sregex-match-string' and `sregex-backref-num'." + sregex--current-sregex) + +; (require 'advice) +; (defadvice save-match-data (around sregex-save-match-data protect) +; (let ((sregex--saved-sregex sregex--current-sregex)) +; (unwind-protect +; ad-do-it +; (setq sregex--current-sregex sregex--saved-sregex)))) +(defmacro sregex-save-match-data (&rest forms) + "Like `save-match-data', but also saves and restores `sregex-info' data." + `(let ((sregex--saved-sregex sregex--current-sregex)) + (unwind-protect + (save-match-data ,@forms) + (setq sregex--current-sregex sregex--saved-sregex)))) + +(defun sregex-replace-match (replacement + &optional fixedcase literal string subexp sregex) + "Like `replace-match', for a regexp made with `sregex'. +This takes one additional optional argument, the `sregex' info, which +can be obtained with `sregex-info'. The SUBEXP argument is adjusted +to allow for \"introduced groups\". If the extra argument is omitted +or nil, it defaults to the current value of (sregex-info)." + (replace-match replacement fixedcase literal string + (and subexp + (sregex-backref-num + subexp + (sregex--value-groups (or sregex + sregex--current-sregex)))))) + +(defun sregex-match-string (count &optional in-string sregex) + "Like `match-string', for a regexp made with `sregex'. +This takes one additional optional argument, the `sregex' info, which +can be obtained with `sregex-info'. The COUNT argument is adjusted to +allow for \"introduced groups\". If the extra argument is omitted or +nil, it defaults to the current value of (sregex-info)." + (match-string (and count + (sregex-backref-num + count + (sregex--value-groups (or sregex + sregex--current-sregex)))) + in-string)) + +(defun sregex-match-string-no-properties (count &optional in-string sregex) + "Like `match-string-no-properties', for a regexp made with `sregex'. +This takes one additional optional argument, the `sregex' info, which +can be obtained with `sregex-info'. The COUNT argument is adjusted to +allow for \"introduced groups\". If the extra argument is omitted or +nil, it defaults to the current value of (sregex-info)." + (match-string-no-properties + (and count + (sregex-backref-num + count + (sregex--value-groups (or sregex + sregex--current-sregex)))) + in-string)) + +(defun sregex-match-beginning (count &optional sregex) + "Like `match-beginning', for a regexp made with `sregex'. +This takes one additional optional argument, the `sregex' info, which +can be obtained with `sregex-info'. The COUNT argument is adjusted to +allow for \"introduced groups\". If the extra argument is omitted or +nil, it defaults to the current value of (sregex-info)." + (match-beginning (sregex-backref-num + count + (sregex--value-groups (or sregex + sregex--current-sregex))))) + +(defun sregex-match-end (count &optional sregex) + "Like `match-end', for a regexp made with `sregex'. +This takes one additional optional argument, the `sregex' info, which +can be obtained with `sregex-info'. The COUNT argument is adjusted to +allow for \"introduced groups\". If the extra argument is omitted or +nil, it defaults to the current value of (sregex-info)." + (match-end (sregex-backref-num + count + (sregex--value-groups (or sregex + sregex--current-sregex))))) + +(defun sregex-match-data (&optional sregex) + "Like `match-data', for a regexp made with `sregex'. +This takes one additional optional argument, the `sregex' info, which +can be obtained with `sregex-info'. \"Introduced groups\" are removed +from the result. If the extra argument is omitted or nil, it defaults +to the current value of (sregex-info)." + (let* ((data (match-data)) + (groups (sregex--value-groups (or sregex + sregex--current-sregex))) + (result (list (car (cdr data)) + (car data)))) + (setq data (cdr (cdr data))) + (while data + (if (car groups) + (setq result (append (list (car (cdr data)) + (car data)) + result))) + (setq groups (cdr groups) + data (cdr (cdr data)))) + (reverse result))) + +(defun sregex--render-tree (tree sregex) + (let ((key (car tree))) + (cond ((eq key 'str) + (cdr tree)) + ((eq key 'or) + (mapconcat '(lambda (x) + (sregex--render-tree x sregex)) + (cdr tree) + "\\|")) + ((eq key 'sequence) + (apply 'concat + (mapcar '(lambda (x) + (sregex--render-tree x sregex)) + (cdr tree)))) + ((eq key 'group) + (concat "\\(" + (sregex--render-tree (cdr tree) sregex) + "\\)")) + ((eq key 'opt) + (concat (sregex--render-tree (cdr tree) sregex) + "?")) + ((eq key '0+) + (concat (sregex--render-tree (cdr tree) sregex) + "*")) + ((eq key '1+) + (concat (sregex--render-tree (cdr tree) sregex) + "+")) + ((eq key 'backref) + (let ((num (sregex-backref-num (cdr tree) sregex))) + (if (> num 9) + (error "sregex: backref number %d too high after adjustment" + num) + (concat "\\" (int-to-string num))))) + (t (error "sregex internal error: unknown tree type %S" + key))))) + +(defun sregex (&rest exps) + "Symbolic regular expression interpreter. +This is exactly like `sregexq' (q.v.) except that it evaluates all its +arguments, so literal sregex clauses must be quoted. For example: + + (sregex '(or \"Bob\" \"Robert\")) => \"Bob\\\\|Robert\" + +An argument-evaluating sregex interpreter lets you reuse sregex +subexpressions: + + (let ((dotstar '(0+ any)) + (whitespace '(1+ (syntax ?-))) + (digits '(1+ (char (?0 . ?9))))) + (sregex 'bol dotstar \":\" whitespace digits)) => \"^.*:\\\\s-+[0-9]+\"" + (progn + (setq sregex--current-sregex (sregex--sequence exps nil)) + (sregex--render-tree (sregex--value-tree sregex--current-sregex) + sregex--current-sregex))) + +(defmacro sregexq (&rest exps) + "Symbolic regular expression interpreter. +This macro allows you to specify a regular expression (regexp) in +symbolic form, and converts it into the string form required by Emacs's +regex functions such as `re-search-forward' and `looking-at'. Here is +a simple example: + + (sregexq (or \"Bob\" \"Robert\")) => \"Bob\\\\|Robert\" + +As you can see, an sregex is specified by placing one or more special +clauses in a call to `sregexq'. The clause in this case is the `or' +of two strings (not to be confused with the Lisp function `or'). The +list of allowable clauses appears below. + +With `sregex', it is never necessary to \"escape\" magic characters +that are meant to be taken literally; that happens automatically. +For example: + + (sregexq \"M*A*S*H\") => \"M\\\\*A\\\\*S\\\\*H\" + +It is also unnecessary to \"group\" parts of the expression together +to overcome operator precedence; that also happens automatically. +For example: + + (sregexq (opt (or \"Bob\" \"Robert\"))) => \"\\\\(Bob\\\\|Robert\\\\)?\" + +It *is* possible to group parts of the expression in order to refer +to them with numbered backreferences: + + (sregexq (group (or \"Go\" \"Run\")) + \", Spot, \" + (backref 1)) => \"\\\\(Go\\\\|Run\\\\), Spot, \\\\1\" + +If `sregexq' needs to introduce its own grouping parentheses, it will +automatically renumber your backreferences: + + (sregexq (opt \"resent-\") + (group (or \"to\" \"cc\" \"bcc\")) + \": \" + (backref 1)) => \"\\\\(resent-\\\\)?\\\\(to\\\\|cc\\\\|bcc\\\\): \\\\2\" + +`sregexq' is a macro. Each time it is used, it constructs a simple +Lisp expression that then invokes a moderately complex engine to +interpret the sregex and render the string form. Because of this, I +don't recommend sprinkling calls to `sregexq' throughout your code, +the way one normally does with string regexes (which are cheap to +evaluate). Instead, it's wiser to precompute the regexes you need +wherever possible instead of repeatedly constructing the same ones +over and over. Example: + + (let ((field-regex (sregexq (opt \"resent-\") + (or \"to\" \"cc\" \"bcc\")))) + ... + (while ... + ... + (re-search-forward field-regex ...) + ...)) + +The arguments to `sregexq' are automatically quoted, but the +flipside of this is that it is not straightforward to include +computed (i.e., non-constant) values in `sregexq' expressions. So +`sregex' is a function that is like `sregexq' but which does not +automatically quote its values. Literal sregex clauses must be +explicitly quoted like so: + + (sregex '(or \"Bob\" \"Robert\")) => \"Bob\\\\|Robert\" + +but computed clauses can be included easily, allowing for the reuse +of common clauses: + + (let ((dotstar '(0+ any)) + (whitespace '(1+ (syntax ?-))) + (digits '(1+ (char (?0 . ?9))))) + (sregex 'bol dotstar \":\" whitespace digits)) => \"^.*:\\\\s-+[0-9]+\" + +Here are the clauses allowed in an `sregex' or `sregexq' expression: + +- a string + This stands for the literal string. If it contains + metacharacters, they will be escaped in the resulting regex + (using `regexp-quote'). + +- the symbol `any' + This stands for \".\", a regex matching any character except + newline. + +- the symbol `bol' + Stands for \"^\", matching the empty string at the beginning of a line + +- the symbol `eol' + Stands for \"$\", matching the empty string at the end of a line + +- (group CLAUSE ...) + Groups the given CLAUSEs using \"\\\\(\" and \"\\\\)\". + +- (sequence CLAUSE ...) + + Groups the given CLAUSEs; may or may not use \"\\\\(\" and \"\\\\)\". + Clauses groups by `sequence' do not count for purposes of + numbering backreferences. Use `sequence' in situations like + this: + + (sregexq (or \"dog\" \"cat\" + (sequence (opt \"sea \") \"monkey\"))) + => \"dog\\\\|cat\\\\|\\\\(sea \\\\)?monkey\" + + where a single `or' alternate needs to contain multiple + subclauses. + +- (backref N) + Matches the same string previously matched by the Nth \"group\" in + the same sregex. N is a positive integer. In the resulting + regex, N may be adjusted to account for automatically introduced + groups. + +- (or CLAUSE ...) + Matches any one of the CLAUSEs by separating them with \"\\\\|\". + +- (0+ CLAUSE ...) + Concatenates the given CLAUSEs and matches zero or more + occurrences by appending \"*\". + +- (1+ CLAUSE ...) + Concatenates the given CLAUSEs and matches one or more + occurrences by appending \"+\". + +- (opt CLAUSE ...) + Concatenates the given CLAUSEs and matches zero or one occurrence + by appending \"?\". + +- (repeat MIN MAX CLAUSE ...) + Concatenates the given CLAUSEs and constructs a regex matching at + least MIN occurrences and at most MAX occurrences. MIN must be a + non-negative integer. MAX must be a non-negative integer greater + than or equal to MIN; or MAX can be nil to mean \"infinity.\" + +- (char CHAR-CLAUSE ...) + Creates a \"character class\" matching one character from the given + set. See below for how to construct a CHAR-CLAUSE. + +- (not-char CHAR-CLAUSE ...) + Creates a \"character class\" matching any one character not in the + given set. See below for how to construct a CHAR-CLAUSE. + +- the symbol `bot' + Stands for \"\\\\`\", matching the empty string at the beginning of + text (beginning of a string or of a buffer). + +- the symbol `eot' + Stands for \"\\\\'\", matching the empty string at the end of text. + +- the symbol `point' + Stands for \"\\\\=\", matching the empty string at point. + +- the symbol `word-boundary' + Stands for \"\\\\b\", matching the empty string at the beginning or + end of a word. + +- the symbol `not-word-boundary' + Stands for \"\\\\B\", matching the empty string not at the beginning + or end of a word. + +- the symbol `bow' + Stands for \"\\\\\\=<\", matching the empty string at the beginning of a + word. + +- the symbol `eow' + Stands for \"\\\\\\=>\", matching the empty string at the end of a word. + +- the symbol `wordchar' + Stands for the regex \"\\\\w\", matching a word-constituent character + (as determined by the current syntax table) + +- the symbol `not-wordchar' + Stands for the regex \"\\\\W\", matching a non-word-constituent + character. + +- (syntax CODE) + Stands for the regex \"\\\\sCODE\", where CODE is a syntax table code + (a single character). Matches any character with the requested + syntax. + +- (not-syntax CODE) + Stands for the regex \"\\\\SCODE\", where CODE is a syntax table code + (a single character). Matches any character without the + requested syntax. + +- (regex REGEX) + This is a \"trapdoor\" for including ordinary regular expression + strings in the result. Some regular expressions are clearer when + written the old way: \"[a-z]\" vs. (sregexq (char (?a . ?z))), for + instance. However, using this can confuse the code that + distinguishes introduced groups from user-specified groups. Avoid + using grouping within a `regex' form. Failing that, avoid using + backrefs if you're using `regex'. + +Each CHAR-CLAUSE that is passed to (char ...) and (not-char ...) +has one of the following forms: + +- a character + Adds that character to the set. + +- a string + Adds all the characters in the string to the set. + +- A pair (MIN . MAX) + Where MIN and MAX are characters, adds the range of characters + from MIN through MAX to the set." + `(apply 'sregex ',exps)) + +(defun sregex--engine (exp combine) + (let* ((val (cond ((stringp exp) + (sregex--make-value (or (not (eq combine 'suffix)) + (= (length exp) 1)) + nil + (cons 'str + (regexp-quote exp)))) + ((symbolp exp) + (funcall (intern (concat "sregex--" + (symbol-name exp))) + combine)) + ((consp exp) + (funcall (intern (concat "sregex--" + (symbol-name (car exp)))) + (cdr exp) + combine)) + (t (error "Invalid expression: %s" exp)))) + (unitp (sregex--value-unitp val)) + (groups (sregex--value-groups val)) + (tree (sregex--value-tree val))) + (if (and combine (not unitp)) + (sregex--make-value t + (cons nil groups) + (cons 'group tree)) + (sregex--make-value unitp groups tree)))) + +(defun sregex--sequence (exps combine) + (if (= (length exps) 1) + (sregex--engine (car exps) combine) + (let ((groups nil) + (trees nil)) ;grows in reverse + (while exps + (let ((val (sregex--engine (car exps) 'concat))) + (setq groups (append groups + (sregex--value-groups val)) + trees (cons (sregex--value-tree val) trees) + exps (cdr exps)))) + (setq trees (nreverse trees)) + (if (eq combine 'suffix) + (sregex--make-value t + (cons nil groups) + (cons 'group + (cons 'sequence trees))) + (sregex--make-value (not (eq combine 'suffix)) + groups + (cons 'sequence trees)))))) + +(defun sregex--group (exps combine) + (let ((val (sregex--sequence exps nil))) + (sregex--make-value t + (cons t (sregex--value-groups val)) + (cons 'group (sregex--value-tree val))))) + +(defun sregex-backref-num (n &optional sregex) + "Adjust backreference number N according to SREGEX. +When `sregex' introduces parenthesized groups that the user didn't ask +for, the numbering of the groups that the user *did* ask for gets all +out of whack. This function accounts for introduced groups. Example: + + (sregexq (opt \"ab\") + (group (or \"c\" \"d\"))) => \"\\\\(ab\\\\)?\\\\(c\\\\|d\\\\)\" + (setq info (sregex-info)) + (sregex-backref-num 1 info) => 2 + +The SREGEX parameter is optional and defaults to the current value of +`sregex-info'." + (let ((groups (sregex--value-groups (or sregex + sregex--current-sregex))) + (result 0)) + (while (and groups (> n 0)) + (if (car groups) + (setq n (1- n))) + (setq result (1+ result) + groups (cdr groups))) + result)) + +(defun sregex--backref (exps combine) + (sregex--make-value t nil (cons 'backref (car exps)))) + +(defun sregex--any (combine) + (sregex--make-value t nil '(str . "."))) + +(defun sregex--opt (exps combine) + (let ((val (sregex--sequence exps 'suffix))) + (sregex--make-value t + (sregex--value-groups val) + (cons 'opt (sregex--value-tree val))))) + +(defun sregex--0+ (exps combine) + (let ((val (sregex--sequence exps 'suffix))) + (sregex--make-value t + (sregex--value-groups val) + (cons '0+ (sregex--value-tree val))))) +(defun sregex--1+ (exps combine) + (let ((val (sregex--sequence exps 'suffix))) + (sregex--make-value t + (sregex--value-groups val) + (cons '1+ (sregex--value-tree val))))) + +(defun sregex--repeat (exps combine) + (let ((min (or (car exps) 0)) + (max (car (cdr exps)))) + (setq exps (cdr (cdr exps))) + (cond ((zerop min) + (cond ((equal max 0) ;degenerate + (sregex--make-value t nil nil)) + ((equal max 1) + (sregex--opt exps combine)) + ((not max) + (sregex--0+ exps combine)) + (t (sregex--sequence (make-list max + (cons 'opt exps)) + combine)))) + ((= min 1) + (cond ((equal max 1) + (sregex--sequence exps combine)) + ((not max) + (sregex--1+ exps combine)) + (t (sregex--sequence (append exps + (make-list (1- max) + (cons 'opt exps))) + combine)))) + (t (sregex--sequence (append exps + (list (append (list 'repeat + (1- min) + (and max + (1- max))) + exps))) + combine))))) + +(defun sregex--or (exps combine) + (if (= (length exps) 1) + (sregex--engine (car exps) combine) + (let ((groups nil) + (trees nil)) + (while exps + (let ((val (sregex--engine (car exps) 'or))) + (setq groups (append groups + (sregex--value-groups val)) + trees (cons (sregex--value-tree val) trees) + exps (cdr exps)))) + (sregex--make-value (eq combine 'or) + groups + (cons 'or (nreverse trees)))))) + +(defmacro sregex--char-range-aux () + '(if start + (let (startc endc) + (if (and (<= 32 start) + (<= start 127)) + (setq startc (char-to-string start) + endc (char-to-string end)) + (setq startc (format "\\%03o" start) + endc (format "\\%03o" end))) + (if (> end start) + (if (> end (+ start 1)) + (setq class (concat class startc "-" endc)) + (setq class (concat class startc endc))) + (setq class (concat class startc)))))) + +(defmacro sregex--char-range (rstart rend) + `(let ((i ,rstart) + start end) + (while (<= i ,rend) + (if (aref chars i) + (progn + (if start + (setq end i) + (setq start i + end i)) + (aset chars i nil)) + (sregex--char-range-aux) + (setq start nil + end nil)) + (setq i (1+ i))) + (sregex--char-range-aux))) + +(defun sregex--char-aux (complement args) + (let ((chars (make-vector 256 nil))) + (while args + (let ((arg (car args))) + (cond ((integerp arg) + (aset chars arg t)) + ((stringp arg) + (mapcar (function + (lambda (c) + (aset chars c t))) + arg)) + ((consp arg) + (let ((start (car arg)) + (end (cdr arg))) + (if (> start end) + (let ((tmp start)) + (setq start end + end tmp))) + ;; now start <= end + (let ((i start)) + (while (<= i end) + (aset chars i t) + (setq i (1+ i)))))))) + (setq args (cdr args))) + ;; now chars is a map of the characters in the class + (let ((class "") + (caret (aref chars ?^))) + (aset chars ?^ nil) + (if (aref chars ?\]) + (progn + (setq class (concat class "]")) + (aset chars ?\] nil))) + (if (aref chars ?-) + (progn + (setq class (concat class "-")) + (aset chars ?- nil))) + (if (aref chars ?\\) + (progn + (setq class (concat class "\\\\")) + (aset chars ?\\ nil))) + + (sregex--char-range ?A ?Z) + (sregex--char-range ?a ?z) + (sregex--char-range ?0 ?9) + + (let ((i 32)) + (while (< i 128) + (if (aref chars i) + (progn + (setq class (concat class (char-to-string i))) + (aset chars i nil))) + (setq i (1+ i)))) + + (sregex--char-range 0 31) + (sregex--char-range 128 255) + + (let ((i 0)) + (while (< i 256) + (if (aref chars i) + (setq class (concat class (format "\\%03o" i)))) + (setq i (1+ i)))) + + (if caret + (setq class (concat class "^"))) + (concat "[" (if complement "^") class "]")))) + +(defun sregex--char (exps combine) + (sregex--make-value t nil (cons 'str (sregex--char-aux nil exps)))) +(defun sregex--not-char (exps combine) + (sregex--make-value t nil (cons 'str (sregex--char-aux t exps)))) + +(defun sregex--bol (combine) + (sregex--make-value t nil '(str . "^"))) +(defun sregex--eol (combine) + (sregex--make-value t nil '(str . "$"))) + +(defun sregex--wordchar (combine) + (sregex--make-value t nil '(str . "\\w"))) +(defun sregex--not-wordchar (combine) + (sregex--make-value t nil '(str . "\\W"))) + +(defun sregex--syntax (exps combine) + (sregex--make-value t nil (cons 'str (format "\\s%c" (car exps))))) +(defun sregex--not-syntax (exps combine) + (sregex--make-value t nil (cons 'str (format "\\S%c" (car exps))))) + +(defun sregex--bot (combine) + (sregex--make-value t nil (cons 'str "\\`"))) +(defun sregex--eot (combine) + (sregex--make-value t nil (cons 'str "\\'"))) + +(defun sregex--point (combine) + (sregex--make-value t nil '(str . "\\="))) + +(defun sregex--word-boundary (combine) + (sregex--make-value t nil '(str . "\\b"))) +(defun sregex--not-word-boundary (combine) + (sregex--make-value t nil '(str . "\\B"))) + +(defun sregex--bow (combine) + (sregex--make-value t nil '(str . "\\<"))) +(defun sregex--eow (combine) + (sregex--make-value t nil '(str . "\\>"))) + + +;; trapdoor - usage discouraged +(defun sregex--regex (exps combine) + (sregex--make-value nil nil (car exps))) + +(provide 'sregex) + +;;; sregex.el ends here + diff -r e4bcb7cb0038 -r 7947a4ea28a8 lisp/net-utils.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/net-utils.el Mon Jun 22 02:03:41 1998 +0000 @@ -0,0 +1,649 @@ +;;; net-utils.el --- Network functions + +;; Author: Peter Breton +;; Created: Sun Mar 16 1997 +;; Keywords: network communications +;; Time-stamp: <1998-06-13 06:19:01 pbreton> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: +;; +;; There are three main areas of functionality: +;; +;; * Wrap common network utility programs (ping, traceroute, netstat, +;; nslookup, arp, route). Note that these wrappers are of the diagnostic +;; functions of these programs only. +;; +;; * Implement some very basic protocols in Emacs Lisp (finger and whois) +;; +;; * Support connections to HOST/PORT, generally for debugging and the like. +;; In other words, for doing much the same thing as "telnet HOST PORT", and +;; then typing commands. +;; +;; PATHS +;; +;; On some systems, some of these programs are not in normal user path, +;; but rather in /sbin, /usr/sbin, and so on. + + +;;; Code: +(eval-when-compile + (require 'comint) + (require 'ffap)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Customization Variables +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defgroup net-utils nil + "Network utility functions." + :prefix "net-utils-" + :group 'comm + :version "20.3" + ) + +(defcustom net-utils-remove-ctl-m + (member system-type (list 'windows-nt 'msdos)) + "If non-nil, remove control-Ms from output." + :group 'net-utils + :type 'boolean + ) + +(defcustom traceroute-program + (if (eq system-type 'windows-nt) + "tracert" + "traceroute") + "Program to trace network hops to a destination." + :group 'net-utils + :type 'string + ) + +(defcustom traceroute-program-options nil + "Options for the traceroute program." + :group 'net-utils + :type '(repeat 'string) + ) + +(defcustom ping-program "ping" + "Program to send network test packets to a host." + :group 'net-utils + :type 'string + ) + +;; On Linux and Irix, the system's ping program seems to send packets +;; indefinitely unless told otherwise +(defcustom ping-program-options + (and (memq system-type (list 'linux 'gnu/linux 'irix)) + (list "-c" "4")) + "Options for the ping program. +These options can be used to limit how many ICMP packets are emitted." + :group 'net-utils + :type '(repeat 'string) + ) + +(defcustom ipconfig-program + (if (eq system-type 'windows-nt) + "ipconfig" + "ifconfig") + "Program to print network configuration information." + :group 'net-utils + :type 'string + ) + +(defcustom ipconfig-program-options + (list + (if (eq system-type 'windows-nt) + "/all" "-a")) + "Options for ipconfig-program." + :group 'net-utils + :type '(repeat 'string) + ) + +(defcustom netstat-program "netstat" + "Program to print network statistics." + :group 'net-utils + :type 'string + ) + +(defcustom netstat-program-options nil + "Options for netstat-program." + :group 'net-utils + :type '(repeat 'string) + ) + +(defcustom arp-program "arp" + "Program to print IP to address translation tables." + :group 'net-utils + :type 'string + ) + +(defcustom arp-program-options + (list "-a") + "Options for arp-program." + :group 'net-utils + :type '(repeat 'string) + ) + +(defcustom route-program + (if (eq system-type 'windows-nt) + "route" + "netstat") + "Program to print routing tables." + :group 'net-utils + :type 'string + ) + +(defcustom route-program-options + (if (eq system-type 'windows-nt) + (list "print") + (list "-r")) + "Options for route-program." + :group 'net-utils + :type '(repeat 'string) + ) + +(defcustom nslookup-program "nslookup" + "Program to interactively query DNS information." + :group 'net-utils + :type 'string + ) + +(defcustom nslookup-program-options nil + "List of options to pass to the nslookup program." + :group 'net-utils + :type '(repeat 'string) + ) + +(defcustom nslookup-prompt-regexp "^> " + "Regexp to match the nslookup prompt." + :group 'net-utils + :type 'regexp + ) + +(defcustom ftp-program "ftp" + "Progam to run to do FTP transfers." + :group 'net-utils + :type 'string + ) + +(defcustom ftp-program-options nil + "List of options to pass to the FTP program." + :group 'net-utils + :type '(repeat 'string) + ) + +(defcustom ftp-prompt-regexp "^ftp>" + "Regexp which matches the FTP program's prompt." + :group 'net-utils + :type 'regexp + ) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Nslookup goodies +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defconst nslookup-font-lock-keywords + (and window-system + (progn + (require 'font-lock) + (list + (list nslookup-prompt-regexp 0 font-lock-reference-face) + (list "^[A-Za-z0-9 _]+:" 0 font-lock-type-face) + (list "\\<\\(SOA\\|NS\\|MX\\|A\\|CNAME\\)\\>" + 1 font-lock-keyword-face) + ;; Dotted quads + (list + (mapconcat 'identity + (make-list 4 "[0-9]+") + "\\.") + 0 font-lock-variable-name-face) + ;; Host names + (list + (let ((host-expression "[-A-Za-z0-9]+")) + (concat + (mapconcat 'identity + (make-list 2 host-expression) + "\\.") + "\\(\\." host-expression "\\)*") + ) + 0 font-lock-variable-name-face) + ))) + "Expressions to font-lock for nslookup.") + +(defvar nslookup-abbrev-table (make-abbrev-table) + "Abbrev table for nslookup.") + +(define-abbrev nslookup-abbrev-table "e" "exit") +(define-abbrev nslookup-abbrev-table "f" "finger") +(define-abbrev nslookup-abbrev-table "h" "help") +(define-abbrev nslookup-abbrev-table "lse" "lserver") +(define-abbrev nslookup-abbrev-table "r" "root") +(define-abbrev nslookup-abbrev-table "s" "set") +(define-abbrev nslookup-abbrev-table "se" "server") +(define-abbrev nslookup-abbrev-table "v" "viewer") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; FTP goodies +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defvar ftp-abbrev-table (make-abbrev-table) + "Abbrev table for ftp.") + +(define-abbrev ftp-abbrev-table "q" "quit") +(define-abbrev ftp-abbrev-table "g" "get") +(define-abbrev ftp-abbrev-table "p" "prompt") +(define-abbrev ftp-abbrev-table "anon" "anonymous") + +(defconst ftp-font-lock-keywords + (and window-system + (progn + (require 'font-lock) + (list + (list ftp-prompt-regexp 0 font-lock-reference-face))))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Utility functions +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun net-utils-remove-ctrl-m-filter (process output-string) + "Remove trailing control Ms." + (let ((old-buffer (current-buffer)) + (filtered-string output-string)) + (unwind-protect + (let ((moving)) + (set-buffer (process-buffer process)) + (setq moving (= (point) (process-mark process))) + + (while (string-match "\r" filtered-string) + (setq filtered-string + (replace-match "" nil nil filtered-string))) + + (save-excursion + ;; Insert the text, moving the process-marker. + (goto-char (process-mark process)) + (insert filtered-string) + (set-marker (process-mark process) (point))) + (if moving (goto-char (process-mark process)))) + (set-buffer old-buffer)))) + +(defmacro net-utils-run-program (name header program &rest args) + "Run a network information program." + (` + (let ((buf (get-buffer-create (concat "*" (, name) "*")))) + (set-buffer buf) + (erase-buffer) + (insert (, header) "\n") + (set-process-filter + (apply 'start-process (, name) buf (, program) (,@ args)) + 'net-utils-remove-ctrl-m-filter) + (display-buffer buf)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Wrappers for external network programs +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;;###autoload +(defun traceroute (target) + "Run traceroute program for TARGET." + (interactive "sTarget: ") + (let ((options + (if traceroute-program-options + (append traceroute-program-options (list target)) + (list target)))) + (net-utils-run-program + (concat "Traceroute" " " target) + (concat "** Traceroute ** " traceroute-program " ** " target) + traceroute-program + options + ))) + +;;;###autoload +(defun ping (host) + "Ping HOST. +If your system's ping continues until interrupted, you can try setting +`ping-program-options'." + (interactive + (list + (progn + (require 'ffap) + (read-from-minibuffer + "Ping host: " + (or (ffap-string-at-point 'machine) ""))))) + (let ((options + (if ping-program-options + (append ping-program-options (list host)) + (list host)))) + (net-utils-run-program + (concat "Ping" " " host) + (concat "** Ping ** " ping-program " ** " host) + ping-program + options + ))) + +;;;###autoload +(defun ipconfig () + "Run ipconfig program." + (interactive) + (net-utils-run-program + "Ipconfig" + (concat "** Ipconfig ** " ipconfig-program " ** ") + ipconfig-program + ipconfig-program-options + )) + +;; This is the normal name on most Unixes. +;;;###autoload +(defalias 'ifconfig 'ipconfig) + +;;;###autoload +(defun netstat () + "Run netstat program." + (interactive) + (net-utils-run-program + "Netstat" + (concat "** Netstat ** " netstat-program " ** ") + netstat-program + netstat-program-options + )) + +;;;###autoload +(defun arp () + "Run the arp program." + (interactive) + (net-utils-run-program + "Arp" + (concat "** Arp ** " arp-program " ** ") + arp-program + arp-program-options + )) + +;;;###autoload +(defun route () + "Run the route program." + (interactive) + (net-utils-run-program + "Route" + (concat "** Route ** " route-program " ** ") + route-program + route-program-options + )) + +;; FIXME -- Needs to be a process filter +;; (defun netstat-with-filter (filter) +;; "Run netstat program." +;; (interactive "sFilter: ") +;; (netstat) +;; (set-buffer (get-buffer "*Netstat*")) +;; (goto-char (point-min)) +;; (delete-matching-lines filter) +;; ) + +;;;###autoload +(defun nslookup-host (host) + "Lookup the DNS information for HOST." + (interactive + (list + (read-from-minibuffer + "Lookup host: " + (or (ffap-string-at-point 'machine) "")))) + (let ((options + (if nslookup-program-options + (append nslookup-program-options (list host)) + (list host)))) + (net-utils-run-program + "Nslookup" + (concat "** " + (mapconcat 'identity + (list "Nslookup" host nslookup-program) + " ** ")) + nslookup-program + options + ))) + + +;;;###autoload +(defun nslookup () + "Run nslookup program." + (interactive) + (comint-run nslookup-program) + (set-process-filter (get-buffer-process "*nslookup*") + 'net-utils-remove-ctrl-m-filter) + (set + (make-local-variable 'font-lock-defaults) + '((nslookup-font-lock-keywords))) + (set + (make-local-variable 'local-abbrev-table) + nslookup-abbrev-table) + (abbrev-mode t) + (make-local-variable 'comint-prompt-regexp) + (setq comint-prompt-regexp nslookup-prompt-regexp) + ) + +;; This is a lot less than ange-ftp, but much simpler. +;;;###autoload +(defun ftp (host) + "Run ftp program." + (interactive "sFtp to Host: ") + (let ((buf (get-buffer-create (concat "*ftp [" host "]*")))) + (set-buffer buf) + (comint-mode) + (comint-exec buf (concat "ftp-" host) ftp-program nil + (if ftp-program-options + (append (list host) ftp-program-options) + (list host))) + (set + (make-local-variable 'font-lock-defaults) + '((ftp-font-lock-keywords))) + + (make-local-variable 'comint-prompt-regexp) + (setq comint-prompt-regexp ftp-prompt-regexp) + + ;; Already buffer local! + (setq comint-output-filter-functions + (list 'comint-watch-for-password-prompt)) + (set + (make-local-variable 'local-abbrev-table) + ftp-abbrev-table) + (abbrev-mode t) + (switch-to-buffer-other-window buf) + )) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Network Connections +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; Full list is available at: +;; ftp://ftp.isi.edu/in-notes/iana/assignments/port-numbers +(defvar network-connection-service-alist + (list + (cons 'echo 7) + (cons 'active-users 11) + (cons 'daytime 13) + (cons 'chargen 19) + (cons 'ftp 21) + (cons 'telnet 23) + (cons 'smtp 25) + (cons 'time 37) + (cons 'whois 43) + (cons 'gopher 70) + (cons 'finger 79) + (cons 'www 80) + (cons 'pop2 109) + (cons 'pop3 110) + (cons 'sun-rpc 111) + (cons 'nntp 119) + (cons 'ntp 123) + (cons 'netbios-name 137) + (cons 'netbios-data 139) + (cons 'irc 194) + (cons 'https 443) + (cons 'rlogin 513) + ) + "Alist of services and associated TCP port numbers. +This list in not complete.") + +;; Workhorse macro +(defmacro run-network-program (process-name host port + &optional initial-string) + (` + (let ((tcp-connection) + (buf) + ) + (setq buf (get-buffer-create (concat "*" (, process-name) "*"))) + (set-buffer buf) + (or + (setq tcp-connection + (open-network-stream + (, process-name) + buf + (, host) + (, port) + )) + (error "Could not open connection to %s" (, host))) + (erase-buffer) + (set-marker (process-mark tcp-connection) (point-min)) + (set-process-filter tcp-connection 'net-utils-remove-ctrl-m-filter) + (and (, initial-string) + (process-send-string tcp-connection + (concat (, initial-string) "\r\n"))) + (display-buffer buf)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Simple protocols +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; Finger protocol +;;;###autoload +(defun finger (user host) + "Finger USER on HOST." + ;; One of those great interactive statements that's actually + ;; longer than the function call! The idea is that if the user + ;; uses a string like "pbreton@cs.umb.edu", we won't ask for the + ;; host name. If we don't see an "@", we'll prompt for the host. + (interactive + (progn + (require 'ffap) + (let* ((answer (read-from-minibuffer "Finger User: " + (ffap-string-at-point 'url))) + (index (string-match (regexp-quote "@") answer)) + ) + (if index + (list + (substring answer 0 index) + (substring answer (1+ index))) + (list + answer + (read-from-minibuffer + "At Host: " + (or (ffap-string-at-point 'machine) ""))))))) + (let* ( + (user-and-host (concat user "@" host)) + (process-name + (concat "Finger [" user-and-host "]")) + ) + (run-network-program + process-name + host + (cdr (assoc 'finger network-connection-service-alist)) + user-and-host + ))) + +(defcustom whois-server-name "whois.internic.net" + "Host name for the whois service." + :group 'net-utils + :type 'string + ) + +;; Whois protocol +;;;###autoload +(defun whois (arg search-string) + "Send SEARCH-STRING to server defined by the `whois-server-name' variable. +With argument, prompt for whois server." + (interactive "P\nsWhois: ") + (let ((host + (if arg + (read-from-minibuffer "Whois server name: ") + whois-server-name)) + ) + (run-network-program + "Whois" + host + (cdr (assoc 'whois network-connection-service-alist)) + search-string + ))) + +(defcustom whois-reverse-lookup-server "whois.arin.net" + "Server which provides inverse DNS mapping." + :group 'net-utils + :type 'string + ) + +;;;###autoload +(defun whois-reverse-lookup () + (interactive) + (let ((whois-server-name whois-reverse-lookup-server)) + (call-interactively 'whois))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; General Network connection +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;;###autoload +(defun network-connection-to-service (host service) + "Open a network connection to SERVICE on HOST." + (interactive + (list + (progn + (require 'ffap) + (read-from-minibuffer "Host: " + (ffap-string-at-point 'machine))) + (completing-read "Service: " + (mapcar + (function + (lambda (elt) + (list (symbol-name (car elt))))) + network-connection-service-alist)))) + (network-connection + host + (cdr (assoc (intern service) network-connection-service-alist))) + ) + +;;;###autoload +(defun network-connection (host port) + "Open a network connection to HOST on PORT." + (interactive "sHost: \nnPort: ") + (network-service-connection host (number-to-string port))) + +(defun network-service-connection (host service) + "Open a network connection to SERVICE on HOST." + (let ( + (process-name (concat "Network Connection [" host " " service "]")) + (portnum (string-to-number service)) + ) + (or (zerop portnum) (setq service portnum)) + (make-comint + process-name + (cons host service)) + (pop-to-buffer (get-buffer (concat "*" process-name "*"))) + )) + +(provide 'net-utils) + +;;; net-utils.el ends here