#!/usr/unsupported/bin/perl
# From tts@ttank.ttank.com Fri Jan 17 18:46:08 1992
# To: Perl-Users@fuggles.acc.Virginia.EDU
# Subject: Re: "ping" in perl? [Sort of]
# From: tts@ttank.ttank.com (Karl Bunch)
# Date: Fri, 17 Jan 1992 16:56:00 GMT
# Reply-To: karl@ttank.com
# SUB: Re: "ping" in perl? [Sort of]
# SUM: tts@ttank.ttank.com (Karl Bunch), karl@ttank.com->Perl-Users@fuggles.acc.Virginia.EDU
# 
# In <1992Jan13.231534.7501@uunet.uu.net> rbj@uunet.uu.net (Root Boy Jim) writes:
# >mfrost@xtort.eng.pyramid.com (Mark Frost) writes:
# >>
# >>Has anyone implemented the "ping" program using perl?
# >
# >Probably not. One must open a raw socket and compose
# >and ICMP ECHO pack. Not impossible, but hairy.
# 
# I have a program (icmp.pl) that listens for ICMP packets, decodes them
# and prints them out as they are received.
# 
# I suspect it's not terribly portable, not is it perfect.  We just use 
# it here so we can monitor or SLIP line when we things aren't working
# correctly.
# 
# I would like to mention that I'm a little sheepish about posting this
# in the middle of this nice little "discussion" regarding perl.  If you
# have problems with the way it's written then don't use it.
# 
# Good luck,
# Karl
# 
#!/usr/bin/perl

# System dependent stuff here....
# really a sockaddr_in...
$sockaddr = "Sna4x8"; # From /usr/include/sys/socket.h
$AF_INET = 2;
$SOCK_STREAM = 1;
$SOCK_DGRAM  = 2;
$SOCK_RAW    = 3;
# From /usr/include/netinet/in.h
$IPPROTO_ICMP= 1;

# From /usr/include/netinet/ip.h
$ip_header = "CCsSsCCSa4a4";

# Open socket
socket(IP, $AF_INET, $SOCK_RAW, $IPPROTO_ICMP) || die "Socket Failed: $!\n";

@icmp_types = (
    "ICMP_ECHOREPLY - echo reply",
    "ICMP_?? - Unknown Type #1",
    "ICMP_?? - Unknown Type #2",
    "ICMP_UNREACH - dest unreachable, codes:",
    "ICMP_SOURCEQUENCH - packet lost, slow down",
    "ICMP_REDIRECT - shorter route, codes:",
    "ICMP_?? - Unknown Type #6",
    "ICMP_?? - Unknown Type #7",
    "ICMP_ECHO - echo service",
    "ICMP_?? - Unknown Type #9",
    "ICMP_?? - Unknown Type #10",
    "ICMP_TIMXCEED - time exceeded, code:",
    "ICMP_PARAMPROB - ip header bad",
    "ICMP_TSTAMP - timestamp request",
    "ICMP_TSTAMPREPLY - timestamp reply",
    "ICMP_IREQ - information request",
    "ICMP_IREQREPLY - information reply",
    "ICMP_MASKREQ - address mask request",
    "ICMP_MASKREPLY - address mask reply",
);

%icmp_codes = (
    # ICMP_UNREACH	/* dest unreachable, codes: */
    "3:0", "ICMP_UNREACH_NET - bad net",
    "3:1", "ICMP_UNREACH_HOST - bad host",
    "3:2", "ICMP_UNREACH_PROTOCOL - bad protocol",
    "3:3", "ICMP_UNREACH_PORT - bad port",
    "3:4", "ICMP_UNREACH_NEEDFRAG - IP_DF caused drop",
    "3:5", "ICMP_UNREACH_SRCFAIL - src route failed",

    # ICMP_REDIRECT	/* shorter route, codes: */
    "5:0", "ICMP_REDIRECT_NET - for network",
    "5:1", "ICMP_REDIRECT_HOST - for host",
    "5:2", "ICMP_REDIRECT_TOSNET - for tos and net",
    "5:3", "ICMP_REDIRECT_TOSHOST - for tos and host",

    # ICMP_TIMXCEED1 time exceeded, code:
    "11:0", "ICMP_TIMXCEED_INTRANS - in transit",
    "11:1", "ICMP_TIMXCEED_REASS - in reass"
);

$| = 1;

while(1) {
    $from = recv(IP, $buf, 4096, 0);

    print "Got something... ",length($from),"\n";
    # Decode IP header
    ($ip_hlv, $ip_tos, $ip_len, $ip_id, $ip_off, $ip_ttl, $ip_p,
     $ip_sum, $ip_src, $ip_dest)
     = unpack($ip_header, $buf);
    $ip_hl = ($ip_hlv & 0xF0) >> 4;
    $ip_v  = ($ip_hlv & 0xF);

    printf "From %d.%d.%d.%d", unpack('C4', $ip_src);
    printf " -> %d.%d.%d.%d\n", unpack('C4', $ip_dest);

    # Pull IP header off of $buf
    $buf = substr($buf, length(pack($ip_header, 0)));

    # Decode ICMP header.
    ($icmp_type, $icmp_code, $icmp_cksum) = unpack("CCn", $buf);

    if($icmp_type > 18) {
	$type_desc = sprintf("ICMP_?? - Unknown Type #%d", $icmp_type);
	$code_desc = sprintf("(%d)", $icmp_code);
    } else {
	$type_desc = $icmp_types[$icmp_type];
	$code_desc = $icmp_codes{"$icmp_type:$icmp_code"};
    }

    print "$type_desc $code_desc\n\n";
}
__END__
# -- 
# % ----------------------------------------------------------------------------
# % Karl Bunch                        ||| UUCP: ..!uunet!cerritos.edu!ttank!karl
# % Think Tank Software               ||| INTERNET: karl@ttank.com
# % "...you'd be surprised how far a hug will go with Geordi, even Worf!" -- Riker
#