[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
Real life Ping command, for your perusal
1In Symbolics 3675 Genera 7.2, System 376.166, Experimental Logical Pathnames Translation Files NEWEST, Utilities 27.31, Server Utilities 28.5,
Hardcopy 118.17, Zmail 165.23, LMFS 102.8, Tape 82.19, Nsage 27.120, Extended Help 18.4, Documentation Database 62.1, Mailer 17.1, IP-TCP 67.8,
Experimental NASA Ames Research Center 5.3, Color 405.13, Color Patches 401.1, Color Support 409.13, Color Doc 408.0, SGD Book Design 2.6,
Experimental Constructs 1, Experimental HST-o-gram 4.0, microcode 3675-FPA-MIC 420, FEP 127, FEP0:>v127-lisp.flod(64), FEP0:>v127-loaders.flod(64),
FEP0:>v127-debug.flod(38), FEP0:>v127-info.flod(64), Machine serial number 2683,
Fix bounds checking on m-X Sort Via Keyboard Macros (from CHA:>u>KANEF>System>Patches-from-Symbolics>Fix bounds checking on m-X Sort Via Keyboard Macros.lisp.4),
This allows nested graphics:With-room-for-graphics. It doesn't do any transformations if called with a stream that has already been transformed. (from CHA:>u>KANEF>System>Patches-from-Symbolics>nested-with-room-for-graphics.lisp.1),
Safer TV:BITMAP-STREAM resource (from CHA:>u>KANEF>System>Patches-from-Symbolics>safer-bitmap-stream-resource.lisp.1),
Safer SI:NOTE-FORCIBLE-ABORT (from CHA:>u>KANEF>System>Patches-from-Symbolics>Safer-NOTE-FORCIBLE-ABORT.lisp.1),
New debugger command Find Package Frame (from CHA:>u>KANEF>System>Private-Patches>com-find-package-frame.lisp.3),
Kanef's environment (from CHA:>u>Kanef>lispm-init), Smaller menus for Zmail sequences (from CHA:>u>Chucko>hacks>smaller-Zmail-menus.lisp.2),
Default Dired spec to *.*.newest (from CHA:>u>Chucko>hacks>zmacs-hacks-7-2),
Provide font for FIX.CONDENSED.TINY (from CHA:>u>Chucko>hacks>fix-for-Brad-Miller's-bug-reports),
Signal appropriate error when bad packets found by NETI:DOMAIN-PARSE-NAME (from CHA:>u>Chucko>hacks>safer-DOMAIN-PARSE-NAME.lisp.1),
Bigger LGP2 fonts (from CHA:>u>Chucko>hacks>bigger-lgp2-fonts)
on Symbolics 3675 #2683 (Bento):
0The file below implements a Ping command, with the following features:
(1) It accepts either an Internet address, which is used verbatim, or a
host name.
(2) Like the Un*x "ping", it keeps trying until either it succeeds or
the user types some character to terminate the attempt.
Note that this is implemented for 7.2. I don't know if this will work
"as is" in 8.0, but the techniques will probably apply equally well
there.
Mailer hacks to follow...
-- Chucko@Charon.ARC.NASA.GOV
Lisp Systems Manager, Intelligent Systems Division
Recom Technologies, Inc. / NASA Ames Research Center
;;; -*- Mode: LISP; Syntax: Common-lisp; Package: TCP; Base: 10 -*-
;;; Version of :ICMP-SEND-ECHO that doesn't require a host.
;;; Warning: This won't work on gateways!
(defmethod (:icmp-send-echo-to-address icmp-protocol) (address &optional length delay)
(setf length (max 8 (or length 8)))
(multiple-value-bind (route local-address foreign-address)
(send network :route-info-for-address address)
(let ((sequence (if (< *icmp-echo-sequence* 65535)
(incf *icmp-echo-sequence*)
(setq *icmp-echo-sequence* 0))))
(send self :get-echo-reply sequence)
(push (ncons sequence) echoes-outstanding)
(send self :icmp-send-echo-internal
route local-address foreign-address 0 length sequence)
(prog1 (process-wait-with-timeout
"ICMP Echo" (or delay (* 5 60))
#'(lambda (icmp sequence)
(not (null (send icmp :echo-reply sequence))))
self sequence)
(send self :get-echo-reply sequence)))))
(defmethod (:route-info-for-address ip-protocol) (address)
(declare (values route local-address foreign-address))
(let* ((route (send self :route-to-address address))
(interface (or (ip-route-interface route)
(first interface-list)))
(local-address (ip-interface-local-address interface))
(mask (ip-interface-mask interface)))
(values route
local-address
(if (eq :local (ip-interface-instance interface))
local-address
(loop for address in (ip-route-foreign-addresses route)
with local-subnet = (logand local-address mask)
when (compare-internet-address (logand address mask) local-subnet)
return address
finally (return (first (ip-route-foreign-addresses route))))))))
(defun send-icmp-echo-to-address (parsed-address &key length timeout)
(send (neti:local-network-of-type :internet)
:icmp-send-echo-to-address
parsed-address length timeout))
;;; More Unix-like PING
;;; Double default TTL
(defparameter *ping-max-n-seconds* 128.)
;;; For value, and effect
(defsubst next-*ICMP-echo-sequence* ()
(if (< *icmp-echo-sequence* 65535)
(incf *icmp-echo-sequence*)
(setq *icmp-echo-sequence* 0)))
(defmethod (:ping-guts icmp-protocol) (route local-address foreign-address length)
(let ((our-echoes-outstanding nil)
(whostate (format nil "Ping ~A" (unparse-internet-address foreign-address))))
(unwind-protect
(loop named ping-guts
as sequence = (next-*icmp-echo-sequence*)
as echo-outstanding = (list* sequence nil)
do
;; clear existing sequence just in case
(send self :get-echo-reply sequence)
;; Maintain our own list of markers, but use same ones as :RECEIVE-IP-PACKET method.
;; That way, we don't have to search whole list for one of ours.
(push echo-outstanding echoes-outstanding)
(push echo-outstanding our-echoes-outstanding)
;; Send echo
(send self :icmp-send-echo-internal
route local-address foreign-address 0 length sequence)
;; give user a chance to bail out
(when (process-wait-with-timeout whostate 60
#'lisp:read-char-no-hang lisp:*standard-input*)
(return-from ping-guts nil))
;; Look for replies
(dolist (echo our-echoes-outstanding)
(when (cdr echo)
(return-from ping-guts t))))
;; Clean up after ourselves
(dolist (echo our-echoes-outstanding)
(send self :get-echo-reply (car echo)))
)))
(defmethod (:ping-address icmp-protocol) (address length)
(multiple-value-bind (route local-address foreign-address)
(send network :route-info-for-address address)
(send self :ping-guts route local-address foreign-address length)))
(defmethod (:ping-host icmp-protocol) (host length)
(multiple-value-bind (route local-address foreign-address)
(send network :route-to-host host)
(send self :ping-guts route local-address foreign-address length)))
(define-ip-protocol 1 icmp-protocol
(:icmp-send-echo :icmp-send-echo-to-address :send-misleading-redirect
:ping-address :ping-host))
(defun ping-address (address &optional length)
(setq length (max 8 (or length 8)))
(etypecase address
(string (setq address (parse-internet-address address)))
(fixnum))
(send (neti:local-network-of-type :internet) :ping-address address length))
(defun ping-host (host &optional length)
(setq length (max 8 (or length 8)))
(setq host (net:parse-host host))
(send (neti:local-network-of-type :internet) :ping-host host length))
;;; New improved PING!
(cp:define-command (com-improved-ping :name "Ping" :command-table "Global")
((host '(or cl-neti::internet-address net:host)
:prompt "Internet address or name of host"
:documentation "Host name or Internet address to ping"
:provide-default t
)
&key
(length '((integer 8 *))
:default 8
:prompt "of packet"
:documentation "Length of ICMP Echo packet; default (and minimum) is 8 bytes.")
)
(format t "~&Pinging ~A. Type any character to quit." host)
(typecase host
(net:host
(condition-case (err)
(format t "~&Host ~A ~:[did not respond~;is up~]."
host
(ping-host host length))
(error
(format t "~&Unable to ping host ~A:~% ~~A~" host err))))
;; Presentation type cl-neti::internet-address returns a string
(string
(condition-case (err)
(format t "~&Host at address ~A ~:[did not respond~;is up~]."
host
(ping-address
(parse-internet-address host)
length))
(error
(format t "~&Unable to ping address ~A:~% ~~A~" host err))))))
;;; *** end of patch file ***