%(
	****************************************************************

		Copyright (c) 1992, Carnegie Mellon University

		All Rights Reserved

	Permission  is  hereby  granted   to  use,  copy,  modify,  and
	distribute  this software  provided  that the  above  copyright
	notice appears in  all copies and that  any distribution be for
	noncommercial purposes.

	Carnegie Mellon University disclaims all warranties with regard
	to this software.  In no event shall Carnegie Mellon University
	be liable for  any special, indirect,  or consequential damages
	or any damages whatsoever  resulting from loss of use, data, or
	profits  arising  out of  or in  connection  with  the  use  or
	performance of this software.

	****************************************************************
)%
MODULE
    TraceRoute (
	ADDRESSING_MODE(EXTERNAL=LONG_RELATIVE,
			NONEXTERNAL=LONG_RELATIVE),
 	IDENT='1.0',
	LIST (ASSEMBLY, BINARY, NOEXPAND),
	LANGUAGE(BLISS32)) =
BEGIN
!++
! TRACEROUTE.BLI	Copyright (c) 1991	Carnegie Mellon University
!
! Description:
!
!	Program to trace a UDP packet's route to a given destination
!
! Author:	Bruce R. Miller		CMU Network Development
! Date:		January 9, 1991
!
! Modifications:
!
!--

LIBRARY 'SYS$LIBRARY:STARLET';
LIBRARY 'CMUIP_SRC:[central]netXPORT';
LIBRARY 'CMUIP_SRC:[central]neterror';
LIBRARY 'CMUIP_SRC:[central]netcommon';
LIBRARY 'CMUIP_SRC:[central]network';
LIBRARY 'CMUIP_SRC:[central]netaux';
LIBRARY 'CMUIP_SRC:[central]netTCPIP';
LIBRARY 'IPNCP';

$Field TRPkt_Fields =
    SET
    TR$Seq	= [$Byte],
    TR$TTL	= [$Byte],
    TR$Time	= [$Bytes(8)]
    TES;
LITERAL
    TRPkt_Length = $Field_Set_Size,
    TR_Header_Size = 10;

MACRO
    TRPkt_Struct = BLOCK[TRPkt_Length] FIELD(TRPkt_Fields) %;

EXTERNAL ROUTINE
    SwapBytes;



OWN
    IP_Chan	: UNSIGNED WORD,
    ICMP_EF	: UNSIGNED LONG,
    TIMR_EF	: UNSIGNED LONG,
    Timer	: VECTOR[8,BYTE],
    Ident	: INITIAL(0),
    Verbose;

OWN
    datalen,
    port	: INITIAL(32768+666),
    SrcAddr	: INITIAL(0),
    TOS 	: INITIAL(0),
    waittime	: INITIAL(5);



ROUTINE Get_NetStat ( Status , NetIOSB : REF NetIO_Status_Block ) =
    BEGIN
    LOCAL
	tmp;

    IF NOT .Status THEN RETURN .Status;
    tmp = .NetIOSB [NSB$Status];
    IF .tmp EQL SS$_ABORT THEN
	RETURN .NetIOSB [NSB$XStatus];

    .tmp
    END;



ROUTINE Sock_SetUp ( HostName_A , IPAddr) =
    BEGIN
    BIND
	HostName 	= .HostName_A : $BBLOCK[DSC$K_S_BLN];
    EXTERNAL ROUTINE
	STR$APPEND	: BLISS ADDRESSING_MODE (GENERAL),
	STR$FREE1_DX	: BLISS ADDRESSING_MODE (GENERAL),
	SYS$QIOW	: BLISS ADDRESSING_MODE (GENERAL),
	Parse_IP_Address,
	This_Host_Name;
    LOCAL
	AddrBuf		: VECTOR [128],
	Sock_IOSB	: NetIO_Status_Block,
!        Info_Block      : Connection_Info_Return_Block,
	TDesc		: $BBLOCK [DSC$K_S_BLN],
	Status;
    BIND
	NamBuf		= AddrBuf	: VECTOR [,BYTE];

! First we set up the IP channel...

    Status = $ASSIGN (DEVNAM = %ASCID'INET$DEVICE', CHAN = IP_Chan);
!!!Hack!!! we need a better error message here.
    IF NOT .Status THEN Signal (.Status);

!!!HACK!!!  We don't check for buffer length here...
    CH$COPY(.HostName[DSC$W_LENGTH], .HostName[DSC$A_POINTER],
		0, .HostName[DSC$W_LENGTH]+1, NamBuf);

    ! Create an IP socket.
    Status = SYS$QIOW (0, .IP_Chan, IP$OPEN, Sock_IOSB,0, 0,
			%REF(0), 0, U$ICMP_Protocol, 4, U$IP_Protocol, 0);
    IF NOT (Status = Get_NetStat (.Status,Sock_IOSB)) THEN Signal (.Status);

    ! Get A-record for domain name
    Status = SYS$QIOW (0, .IP_Chan, IP$GTHST, Sock_IOSB,0, 0,
			AddrBuf, 512, GTH_NAMADR, AddrBuf, 0, 0);
    IF NOT (Status = Get_NetStat (.Status,Sock_IOSB)) THEN
	BEGIN
	IF NOT Parse_IP_Address ( HostName , .IPaddr ) THEN
	    BEGIN
	    Signal(.Status);
	    RETURN 0
	    END
	END
    ELSE
	! Get the final destination address.
	!!!HACK!!! Check addr count in AddrBuf[0]
	.IPAddr = .AddrBuf[1];

    ! Get A-record for source
    $Init_DynDesc (TDesc);
    This_Host_Name (TDesc);			  
    Status = STR$APPEND (TDesc, %ASCID %CHAR(0));
    IF NOT .Status THEN Signal (.Status);

    Status = SYS$QIOW (0, .IP_Chan, IP$GTHST, Sock_IOSB,0, 0,
			AddrBuf, 512, GTH_NAMADR, .TDesc[DSC$A_POINTER], 0, 0);
    IF NOT (Status = Get_NetStat (.Status,Sock_IOSB)) THEN Signal (.Status);

    Status = STR$FREE1_DX (TDesc);
    IF NOT .Status THEN Signal (.Status);

    ! Get our source address.
!!!HACK!!! Check addr count in AddrBuf[0]
    SrcAddr = .AddrBuf[1];

    SS$_NORMAL
    END;



ROUTINE Send_Probe ( Target , TTL , Seq ) =
    BEGIN
    EXTERNAL ROUTINE
	SYS$QIOW	: BLISS ADDRESSING_MODE (GENERAL);
    LOCAL
	datalen,
	HdBuff		: VECTOR [5] INITIAL(REP 5 of (0)),
	Packet		: VECTOR [512,BYTE],   !!!HACK!!! (hardwire)
	NetIOSB		: NetIO_Status_Block,
	Status;
    BIND
	IPHdr	= HdBuff	: IP_Structure,
	UDPHdr	= Packet	: UDPkt_Structure,
	TRPkt	= UDPHdr[UP$Data]	: TRPkt_Struct;

    datalen = IP_Size*4 + UDP_Header_Size + TR_Header_Size;

    ! Set up the IP header
    IPHdr[IPH$Dest]		= .Target;
    IPHdr[IPH$Source]		= .SrcAddr;
    IPHdr[IPH$Type_service]	= .TOS;
    IPHdr[IPH$IHL]		= 5;
    IPHdr[IPH$Version]		= 4;
    IPHdr[IPH$Ident]		= .IDent;
    IPHdr[IPH$Flags]		= 0;
    IPHdr[IPH$Checksum]		= 0;
    IPHdr[IPH$Protocol]		= UDP_Protocol;
    IPHdr[IPH$Fragment_offset]	= 0;
    IPHdr[IPH$Total_Length]	= .datalen;

    IPHdr[IPH$TTL]		= .TTL;

    ! Set up the UDP header
    UDPHdr[UP$Source_Port]	= .Ident;
    UDPHdr[UP$Dest_Port]	= .Port + .Seq;
    UDPHdr[UP$Length] 		= .datalen - IP_Size*4;
    UDPHdr[UP$Checksum]		= 0;
    SwapBytes ( 4 , UDPHdr );

    ! Set up the data
    TRpkt[TR$Seq]		= .Seq;
    TRpkt[TR$TTL]		= .TTL;
    $GETTIM ( TIMADR = TRpkt[TR$Time] );

    ! Pump that sucker onto the wire
    Status = SYS$QIOW(0,.IP_Chan,IP$SEND,NetIOSB,0,0,
			Packet,.datalen - IP_Size*4,0,1,5,IPHdr);
    IF NOT (Status = Get_NetStat (.Status,NetIOSB)) THEN Signal (.Status);

    SS$_NORMAL
    END;



ROUTINE ShootOnce (Target,TTL,Seq,Last_Addr_A,Router_A,Unreachable) =
    BEGIN
    EXTERNAL ROUTINE
	LIB$SUB_TIMES	: BLISS ADDRESSING_MODE (GENERAL),
	STR$FREE1_DX	: BLISS ADDRESSING_MODE (GENERAL),
	SYS$CLREF	: BLISS ADDRESSING_MODE (GENERAL),
	SYS$WAITFR	: BLISS ADDRESSING_MODE (GENERAL),
	SYS$QIO		: BLISS ADDRESSING_MODE (GENERAL),
	SYS$QIOW	: BLISS ADDRESSING_MODE (GENERAL),
	ADDR_2_Name;
    LOCAL
	ICMP_Chan	: UNSIGNED WORD,
	Data		: VECTOR [512,BYTE],   !!!HACK!!! (hardwire)
	Hdr		: IPADR$ADDRESS_BLOCK,
	NetIOSB		: NetIO_Status_Block,
	FlagStat,
	mask,
	Router_Name	: $BBLOCK [DSC$K_S_BLN],
	time_diff	: VECTOR [2],
	time_now	: VECTOR [2],
	time_then	: VECTOR [2],
	trip_time,
	type,code,
	Got_There	: INITIAL(0),
	Status, Status2;
    BIND
	UDPHdr	= Data			: UDPkt_Structure,
	TRPkt	= UDPHdr[UP$Data]	: TRPkt_Struct,
	Last_Addr = .Last_Addr_A,
	Router = .Router_A;

    ! Create an ICMP socket.
    Status = $ASSIGN (DEVNAM = %ASCID'INET$DEVICE', CHAN = ICMP_Chan);
    IF NOT .Status THEN Signal (.Status);

    Status = SYS$QIOW (0, .ICMP_Chan, IP$OPEN, NetIOSB,0, 0,
			%REF(0), 0, 0, 4, U$ICMP_Protocol, 0);
!    PrintTT('Stat = !XL  NSB$Stat = !XL NSB$XStat = !XL',
!		.Status,
!		.NetIOSB [NSB$Status],
!		.NetIOSB [NSB$XStatus]);
    IF NOT (Status = Get_NetStat (.Status,NetIOSB)) THEN Signal (.Status);

    ! Start up a read on the ICMP socket w/ EF
    Status = SYS$CLREF ( .ICMP_EF );
    IF NOT .Status THEN RETURN Signal (.Status);
    Status2 = SYS$QIO(.ICMP_EF,.ICMP_Chan,IP$RECEIVE,NetIOSB,0,0,
			Data, 512, Hdr, 0, 0, 0);
    IF NOT .Status THEN RETURN Signal (.Status);

    ! Set the timer to go off w/ EF
    Status = $CLREF ( EFN = .TIMR_EF );
    IF NOT .Status THEN RETURN Signal (.Status);
    Status = $SETIMR ( EFN = .TIMR_EF , DAYTIM = Timer );
    IF NOT .Status THEN RETURN Signal (.Status);

    ! Probe the net
    $GETTIM ( timadr = time_then );
    Status = Send_Probe(.Target,.TTL,.Seq);
    IF NOT .Status THEN RETURN 0;

    ! Wait for a reply
!!!HACK!!!  This should be in a loop!
    mask = 1^(.ICMP_EF AND %x'1F') OR 1^(.TIMR_EF AND %x'1F');
    Status = $WFLOR ( EFN = .ICMP_EF , 
		      MASK = .mask );
    IF NOT .Status THEN RETURN Signal (.Status);

    $GETTIM ( timadr = time_now );

    Status = $READEF ( EFN = .ICMP_EF , STATE = FlagStat );
    IF NOT .Status THEN RETURN Signal (.Status);

    Status = $CANTIM();
    IF NOT .Status THEN RETURN Signal (.Status);

    IF ( .FlagStat AND 1^(.ICMP_EF AND %x'1F') ) EQL 0 THEN
	BEGIN
	PrintTT(' *');
	NET$CLOSE ( IOChan = .ICMP_Chan );
	$DASSGN ( CHAN = .ICMP_Chan );
	RETURN
	END;

    IF NOT (Status = Get_NetStat (.Status2,NetIOSB)) THEN Signal (.Status);

    type = .Hdr[IPADR$CODE];	code = .Hdr[IPADR$TYPE];
    Router = .Hdr[IPADR$SRC_Host];

    ! Print router name?
    IF .Last_Addr NEQU .Router THEN
	BEGIN
	$Init_DynDesc (Router_Name);
	IF .Router NEQ 0 THEN
	    BEGIN
	    Status = ADDR_2_NAME (.Router, Router_Name);
	    IF .Status THEN
		PrintTT(' !AS',Router_Name)
	    END;
	PrintTT(' (!UB.!UB.!UB.!UB)',
		.Router<0,8,0>, .Router<8,8,0>,
		.Router<16,8,0>, .Router<24,8,0>);
!	IF .Router_Name[DSC$W_LENGTH] GTR 0 THEN
!	    STR$FREE1_DX (Router_Name);
	END;

    ! Compute Round-Trip-Time
    LIB$SUB_TIMES ( time_now , time_then , time_diff );
    trip_time = (-.time_diff[0]) / 10000;

    ! A noteworthy packet?
    IF ( (.type EQL ICM_TEXCEED) AND (.code EQL ICM_TEXCEED_INTRANS) ) OR
	(.type EQL ICM_DUNREACH) THEN
	BEGIN
	PrintTT('  !UL ms',.trip_time);
	IF (.type EQL ICM_DUNREACH) THEN
	    BEGIN
	    .Unreachable = ..Unreachable + 1;
	    SELECTONE .code OF
		SET
		[ICM_DUNR_PORT] :
			BEGIN
			Got_There = 1;
			.Unreachable = ..Unreachable - 1;
			PrintTT(' !!');
			END;
		[ICM_DUNR_NET] :
			PrintTT(' !!N');
		[ICM_DUNR_HOST] :
			PrintTT(' !!H');
		[ICM_DUNR_PROTOCOL] :
			PrintTT(' !!P');
		[ICM_DUNR_FRAGMENT] :
			PrintTT(' !!F');
		[ICM_DUNR_SRCROUTE] :
			PrintTT(' !!S');
		[ICM_DUNR_NET] :
			PrintTT(' !!N');
		TES;
	    END;
	END
    ELSE	! Invalid reply
	PrintTT(' *');

    NET$CLOSE ( IOChan = .ICMP_Chan );
    $DASSGN ( CHAN = .ICMP_Chan );

    .Got_There
    END;



GLOBAL ROUTINE TraceRoute ( HostName_A , MaxHops , Verbose_Flag )
								: NOVALUE =
!++
! Functional Description:
!
!--

    BEGIN
    EXTERNAL ROUTINE
	LIB$GET_EF			: BLISS ADDRESSING_MODE (GENERAL),
	LIB$CVT_TO_INTERNAL_TIME	: BLISS ADDRESSING_MODE (GENERAL),
	LIB$FREE_EF			: BLISS ADDRESSING_MODE (GENERAL);
    LOCAL
	Status,
	nprobes : INITIAL(3),
	IPaddr, Last_Addr, Router,
	Item_List,
	TTL,
	Seq,
	RC;
    LABEL
	X;

    datalen = 32;
    verbose = 0;

    IF NOT Sock_Setup(.HostName_A, IPaddr) THEN
	Return 0;

    PrintTT('!/TraceRoute to !AS (!UB.!UB.!UB.!UB)!/', .HostName_A,
	  .IPaddr<0,8,0>, .IPaddr<8,8,0>, .IPaddr<16,8,0>, .IPaddr<24,8,0> );

    Verbose = .Verbose_flag;
    TTL = 0;
    Seq = 0;

    Ident = 0;
    Item_List = 0;
    $GETJPI ( PIDADR = ident , ITMLST = Item_List );
    ident<16,31> = 0; !Mask off high word (in case this is a cluster.)

    Status = LIB$GET_EF ( ICMP_EF );
    IF NOT .Status THEN Signal (.Status);
    Status = LIB$GET_EF ( TIMR_EF );
    IF NOT .Status THEN Signal (.Status);
    LIB$CVT_TO_INTERNAL_TIME ( %ref(LIB$K_DELTA_SECONDS),waittime,Timer);

    WHILE (.TTL LSS .MaxHops) DO
	BEGIN
	LOCAL
	    Got_There : INITIAL(0),
	    Unreachable : INITIAL(0);

	TTL = .TTL + 1;
	PrintTT('!2UB ', .TTL);
	Last_Addr = 0;

	INCR I FROM 1 TO .nprobes DO
	    BEGIN
	    Seq = .Seq + 1;
	    RC = ShootOnce(.IPaddr,.TTL,.Seq,Last_Addr,Router,Unreachable);
	    Got_There = .Got_There + .RC;
	    Last_Addr = .Router;
	    END;
	PrintTT('!/');

	IF (.Got_There GTR 0) OR (.Unreachable GEQ .nProbes-1) THEN
	    EXITLOOP;
	END;

    LIB$FREE_EF ( ICMP_EF );
    LIB$FREE_EF ( TIMR_EF );

    NET$CLOSE ( IOChan = .IP_Chan );
    $DASSGN ( CHAN = .IP_Chan );

    PrintTT('Bye bye!/')
    END;

END ELUDOM