icmp.dllを利用したwin32版ping

win32-ping.lsp

#!newlisp

;; PING for newLISP (win32)
;;
;; Usage:
;;   > newlisp ping.lsp localhost
;;   > newlisp ping.lsp -w 2000 gist.github.com
;;
;; License:
;;   MIT License

(import "icmp.dll" "IcmpCreateFile")
(import "icmp.dll" "IcmpCloseHandle")
(import "icmp.dll" "IcmpSendEcho")
(import "ws2_32.dll" "inet_addr")
(import "ws2_32.dll" "inet_ntoa")

; typedef struct icmp_echo_reply {
;   IPAddr                       Address;
;   ULONG                        Status;
;   ULONG                        RoundTripTime;
;   USHORT                       DataSize;
;   USHORT                       Reserved;
;   PVOID                        Data;
;   struct ip_option_information  Options;
; } ICMP_ECHO_REPLY, *PICMP_ECHO_REPLY;
;; xxx: Why pack/unpack not have *void ?
(define icmp_echo_reply "lu lu lu u u lu lu")

(define (ping host (timeout 1000))
  (letn ((data "SEND ICMP DATA")
         (hIcmpFile (IcmpCreateFile))
         ;; replyBufferLength = sizeof(ICMP_ECHO_REPLY32) + strlen(data) + 1
         (replyBufferLength (+ 29 (length data) 1))
         (replyBuffer (dup "\000" replyBufferLength))
         (status 0)
         (responseTime))
    (setq host (or (net-lookup host true)
                   (throw-error (list (last (net-error)) host))))
    (setq responseTime
          (time (setq status
                      (IcmpSendEcho hIcmpFile
                                    (inet_addr host)
                                    data (length data)
                                    0
                                    replyBuffer (length replyBuffer)
                                    timeout))
                ))
    (IcmpCloseHandle hIcmpFile)
    (if (!= status 0)
        (let ((reply (unpack icmp_echo_reply replyBuffer)))
          (list (cons "Host" (get-string (inet_ntoa (reply 0))))
                (cons "RTT"  (reply 2))
                (cons "Time" (mul responseTime 1000)) ; millisec to microsec
                ))
        nil)
    ))

;; __main__

(setq $host (main-args -1))
(setq $timeout 1000)            ; millisec

(when (<= (length (main-args)) 2)
  (println (format "Usage: newlisp ping.lsp [-w TIMEOUT] TARGET"))
  (exit 1))

(dolist (arg (main-args))
  (case arg
    ("-w" (setq $timeout (int (main-args (+ $idx 1)))))
    ))

(println (ping $host $timeout))

(exit)