Note: This is not the complete source code--just the main source file.
You can download the full source (with include files) from our sample code archive by clicking on the diskette icons.

Traceroute.inc.vbs.asp

<!-- #include file="HexGadgets.inc.vbs.asp" -->
<!-- #include file="HexIcmp.inc.vbs.asp" -->
<!-- #include file="HexLookup.inc.vbs.asp" -->
<!-- #include file="UtilityVars.inc.vbs.asp" -->
<%
'// Traceroute engine
'// version 2002-08-14
'// 
'// This file defines a class that implements the Traceroute
'// engine. Use with Utility.inc.vbs.asp.
'//
'// Traceroute maps out the path from one host on the Internet
'// to another by sending out a series of ICMP echo requests
'// with increasing time-to-live settings. The routers along
'// the path reveal their addresses when they return TTL-expired
'// error messages.
'//
'// Inputs (form variables):
'//   - addr       (string) Domain or ip address of destination host
'//   - no_resolve (bool)   Don't resolve IP addresses to domain names
'//
'// HexGadgets (components) required:
'//   - HexIcmp
'//   - HexLookup
'// Info: http://www.HexGadgets.com/
'// Download: http://www.hexillion.com/download/HexGadgets.exe
'//
'// Other dependencies:
'//   - HexGadgets.inc.vbs.asp
'//   - HexIcmp.inc.vbs.asp
'//   - HexLookup.inc.vbs.asp
'//   - UtilityVars.inc.vbs.asp
'//   - VBScript 5.0 or later
'//     Get the latest at http://msdn.microsoft.com/scripting/
'//
'// History:
'// 2002-08-14  Created, based on old AspTrace sample
'//
'// Copyright 2002 Hexillion Technologies. All rights reserved.
'// 
'// THIS CODE AND INFORMATION IS PROVIDED "AS IS" WITHOUT WARRANTY
'// OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING BUT NOT
'// LIMITED TO THE IMPLIED WARRANTIES OF MERCHANTIBILITY AND/OR
'// FITNESS FOR A PARTICULAR PURPOSE.

class Traceroute

	property Get Name()
		Name = "Traceroute"
	end property
	
	property Get Desc()
		Desc = "Trace the path from this server to another"
	end property
	
	property Get ViewSourceURL()
		ViewSourceURL = "http://www.hexillion.com/samples/view_src.asp?name=Traceroute.inc.vbs.asp"
	end property
	
	property Get DownloadSourceURL()
		DownloadSourceURL = "http://www.hexillion.com/samples/#Traceroute"
	end property
	
	private m_oIcmp      '// HexIcmp object
	private m_oLkup      '// HexLookup object
	private m_sAddr      '// DNS server address
	private m_bNoResolve '// Don't resolve IP addresses to domain names
	private m_lLkupErr   '// HexLookup license error
	private m_lIcmpErr   '// HexIcmp license error

	Private Sub Class_Initialize()
		'// Create objects
		set m_oLkup = Server.CreateObject( "Hexillion.HexLookup" )
		set m_oIcmp = Server.CreateObject( "Hexillion.HexIcmp" )
		
		'// Save license error codes
		m_lLkupErr = m_oLkup.Error
		m_lIcmpErr = m_oIcmp.Error
	end sub

	Private Sub Class_Terminate()
		set m_oLkup = nothing
		set m_oIcmp = nothing
	end sub
	
	Sub WriteForm()
		'// Check for form input, set defaults
		m_sAddr = GetVar( m_sAddr, "addr",    c_varDomain,        null )
		m_sAddr = GetVar( m_sAddr, c_varNone, c_varIpAddr,        null )
		m_sAddr = GetVar( m_sAddr, c_varNone, c_varDerivedDomain, null )
		m_sAddr = GetVar( m_sAddr, c_varNone, c_varDerivedIpAddr, request( "REMOTE_HOST" ) )
		
		m_bNoResolve  = cbool( GetVar( m_bNoResolve, "no_resolve", c_varNone, false ) )
		
		WriteLn "<form method=""POST"" action=""" & request( "SCRIPT_NAME" ) & """ id=form1>"
		WriteLn "	<table cellpadding=""5"" border=""0"" cellspacing=""0"">"
		WriteLn "		<tr>"
		WriteLn "			<td align=""right"">from</td>"
		WriteLn "			<td width=""2"">&nbsp;</td>"
		WriteLn "           <td><strong>" & request( "SERVER_NAME" ) & " [" & request( "LOCAL_ADDR" ) & "]</strong></td>"
		WriteLn "			<td>&nbsp;</td>"
		WriteLn "		</tr>"
		WriteLn "		<tr>"
		WriteLn "			<td align=""right"">to</td>"
		WriteLn "			<td width=""2"">&nbsp;</td>"
		WriteLn "			<td class=""bugfix"">"
		WriteLn "				<input type=""text"" name=""addr"" size=""30"" value=""" & Server.HtmlEncode( m_sAddr ) & """>"
		WriteLn "			</td>"
		WriteLn "			<td>&nbsp;</td>"
		WriteLn "		</tr>"
		WriteLn "		<tr>"
		WriteLn "			<td>&nbsp;</td>"
		WriteLn "			<td width=""2"">&nbsp;</td>"
		Response.Write "			<td valign=""bottom""><input type=""checkbox"" value=""true"" name=""no_resolve"""
		if m_bNoResolve then Response.Write " checked"
		WriteLn "> don't resolve IP addresses</td>"
		
		WriteLn "			<td><input border=""0"" src=""btn_go.gif"" name=""go"" type=""image"" width=""35"" height=""21""></td>"

		WriteLn "		</tr>"
		WriteLn "	</table>"
		WriteLn "</form>"
	end sub
	
	
	sub WriteOutput()
		if "" <> request( "addr" ) then DoTraceroute
		
		'// Main work is put off in separate routine
		'// so "exit sub" statements won't skip the following
		WriteLicenseWarning "HexIcmp", m_oIcmp, m_lIcmpErr
		WriteLicenseWarning "HexLookup", m_oLkup, m_lLkupErr
	end sub
	
	
	private sub DoTraceroute()
		'// Condition input address
		m_sAddr = trim( m_sAddr )
					
		'// Try to get an IP address
		dim lAddr
	    lAddr = m_oLkup.LookUp( m_sAddr )
	    
		if 0 = lAddr then
			WriteLn "<p>Lookup of <span class=""ipaddr"">" & Server.HtmlEncode( m_sAddr ) & "</span> failed.</p>"
			exit sub
		end if

	    '// Get ready to set cookie
	    InitCookieVars
	    	
		'// Write input variables to non-persistent cookie
		'// for use with other utilities and future calls to
		'// this one
	    '// If the input was an IP address...
	    if m_sAddr = m_oLkup.AddrToString( lAddr ) then
			SetVar c_varIpAddr, m_sAddr
		else
			SetVar c_varDomain, m_sAddr
			SetVar c_varDerivedIpAddr, lAddr
		end if

		WriteLn "<p>Tracing route to <span class=""ipaddr"">" & Server.HtmlEncode( m_sAddr ) & " [" & m_oLkup.AddrToString( lAddr ) & "]</span>...</p>"

		WriteLn "<table border=""0"" cellspacing=""1"" cellpadding=""3"">"
		WriteLn "	<tr>"
		WriteLn "		<td class=""hdr"" width=""20"" align=""right"" valign=""bottom"">hop</td>"
		WriteLn "		<td class=""hdr"" width=""40"" align=""right"" valign=""bottom"">rtt</td>"
		WriteLn "		<td class=""hdr"" width=""40"" align=""right"" valign=""bottom"">rtt</td>"
		WriteLn "		<td class=""hdr"" width=""40"" align=""right"" valign=""bottom"">rtt</td>"
		WriteLn "		<td class=""hdr"" width=""4"" valign=""bottom"">&nbsp;</td>"
		WriteLn "		<td class=""hdr"" width=""130"" valign=""bottom"">ip address</td>"
		if not m_bNoResolve then
			WriteLn "		<td class=""hdr"" valign=""bottom"">domain name</td>"
		end if
		WriteLn "	</tr>"
		WriteLn "</table>"

		const maxMissing = 4  '// Max missing hops before aborting trace
		dim iMissingCount

		Dim i, j, lRTT, iMax, iErr, bAbort, lRecvAddr
		dim sRtt(3), sAddr, sFQDN

		iMax = 30
		i = 0
		m_oIcmp.Timeout = 1000
		bAbort = false
		Do While lRecvAddr <> lAddr And i < iMax and not bAbort and Response.IsClientConnected
			i = i + 1
			Erase sRtt
			sAddr = ""
			sFQDN = ""
			lRecvAddr = 0
			m_oIcmp.SendTtl = i
			j = 0
			Do While j < 3 and not bAbort
				j = j + 1
				lRTT = m_oIcmp.Ping(lAddr)
				If lRTT < 0 And m_oIcmp.Error <> hexIcmpErrTtlExpiredTransit Then
					iErr = m_oIcmp.Error
					Select Case iErr
						Case hexIcmpErrDestHostUnreachable
							sRtt( j ) = "Host unreachable"
							bAbort = True
					   Case hexIcmpErrDestNetUnreachable
							sRtt( j ) = "Network unreachable"
							bAbort = True
						Case hexIcmpErrSourceQuench
							sRtt( j ) = "SQ"
						Case hexIcmpErrReqTimedOut
							sRtt( j ) = "*"
						Case Else
							sRtt( j ) = "Err:" & iErr
							bAbort = True
					End Select
				Else
					lRecvAddr = m_oIcmp.RecvAddr
					sRtt( j ) = m_oIcmp.RecvRtt
				End If
			Loop
	    
			'// If any of the 3 pings succeeded...
			If lRecvAddr <> 0 Then
				'// Print the responding IP address and domain name
				sAddr = m_oLkup.AddrToString(lRecvAddr)
				
				if not m_bNoResolve then
					sFQDN = m_oLkup.ReverseLookUp(lRecvAddr)
				end if

				'// Reset our count of "missing" hops
				iMissingCount = 0
			else
				'// We have another "missing" hop
				iMissingCount = iMissingCount + 1

				'// Abort if we've had too many consecutive missing
				if iMissingCount >= maxMissing then bAbort = true
			End If

			WriteLn "<table border=""0"" cellspacing=""1"" cellpadding=""3"">"
			WriteLn "	<tr>"
			WriteLn "		<td width=""20"" align=""right"">" & i & "</td>"
			WriteLn "		<td width=""40"" align=""right"">" & sRtt( 1 ) & "</td>"
			WriteLn "		<td width=""40"" align=""right"">" & sRtt( 2 ) & "</td>"
			WriteLn "		<td width=""40"" align=""right"">" & sRtt( 3 ) & "</td>"
			WriteLn "		<td width=""4"">&nbsp;</td>"
			WriteLn "		<td width=""130"">" & sAddr & "</td>"
			if not m_bNoResolve then
				WriteLn "		<td>" & Server.HtmlEncode( sFQDN ) & "</td>"
			end if
			WriteLn "	</tr>"
			WriteLn "</table>"

			Response.Flush
		Loop

		if bAbort then
			Response.Write "<p>Trace aborted</p>"
		else
			Response.Write "<p>Trace complete</p>"
		end if
		
	end sub
	
	
	private sub WriteLn( s )
		Response.Write s & vbcrlf
	end sub
		
end class
%>