dns-browse 1.9-7 / usr / bin / dns_browse

#!/usr/bin/wish -f

#
# dns_browse
# Copyright (C) 1997 by John Heidemann
# $Id: dns_browse,v 1.25 2002/05/13 16:43:24 johnh Exp $
# 
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License
# as published by the Free Software Foundation; either version 2
# of the License, or any later version.
# 
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
# 
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
# 

global dns_tree types 
set dns_tree "dns_tree"
set prog "dns_browse"
set maximal_types {A CNAME HINFO LOC MX NS PTR TXT}
set default_types {A CNAME NS TXT}
set user_types {}
set required_types {i iz m mx}
set www_hosts_only 0

proc usage {} {
        global prog dns_tree
	puts stderr "usage: $prog \[-t TYPE ...\] starting_domain_name"
        puts stderr {options:
    -t TYPE show only records of these TYPE (repeat for multiple types)
		(the ``all'' type does everything I know about)
    -w      match only web hosts
}
        puts stderr "Requires $dns_tree to be in the path."
	exit 1
}

# toggle_window is from nam-1
proc toggle_window w {
	if ![winfo exists $w] { build$w $w }
	global created$w
	if ![info exists created$w] {
		set created$w 1
		wm transient $w .
		update idletasks
		set x [winfo rootx .]
		set y [winfo rooty .]
		incr y [winfo height .]
		incr y -[winfo reqheight $w]
		incr y -20
 		# adjust for virtual desktops
		incr x [winfo vrootx .]
		incr y [winfo vrooty .]
		if { $y < 0 } { set y 0 }
		if { $x < 0 } {
			set x 0
		} else {
			set right [expr [winfo screenwidth .] - \
					   [winfo reqwidth $w]]
			if { $x > $right } {
				set x $right
			}
		}
		wm geometry $w +$x+$y
		wm deiconify $w
	} elseif [winfo ismapped $w] {
		wm withdraw $w
	} else {
		wm deiconify $w
	}
}

#
# formatted_text is stolen from dontspace
# <http://www.isi.edu/~johnh/SOFTWARE/JACOBY/>
# (with permission :-)
#
proc formatted_text {w text} {
	# NEEDSWORK: font selection should be configurable.
	#
	# If you use this code elsewhere, please follow two conscious
	# style choices.  First, wide things are hard to read
	# (50 chars is about the most reasonable---consider newspaper
	# columns).  Second, we allow the user to resize the window.
	# (The user should always have control, even to do stupid things.)
	#
	frame $w.f

	set wt $w.f.t
	text $wt \
		-relief raised -bd 2 -yscrollcommand "$w.f.s set" \
		-setgrid true -wrap word \
		-width 60 -padx 4 -pady 4 \
		-font -*-Times-Medium-R-*-140-*
	set defFg [lindex [$wt configure -foreground] 4]
	set defBg [lindex [$wt configure -background] 4]
	$wt tag configure italic -font -*-Times-Medium-I-Normal-*-140-*
	$wt tag configure computer -font -*-Courier-Medium-R-Normal-*-120-*
	$wt tag configure big -font -*-Times-Bold-R-Normal-*-180-*
	$wt tag configure reverse -foreground $defBg -background $defFg
	pack $wt -side left -expand 1 -fill both

	set ws $w.f.s
	scrollbar $ws -relief flat -command "$w.f.t yview"
	pack $ws -side right -expand yes -fill both

	pack $w.f

	#
	# Scan the text for tags.
	#
	$wt mark set insert 0.0
	set t $text
	while { [regexp -indices {<([^@>]*)>} $t match inds] == 1 } {
		set start [lindex $inds 0]
		set end [lindex $inds 1]

		set keyword [string range $t $start $end]
		# puts stderr "tag $keyword found at $inds"

		# insert the left hand text into the thing
		set oldend [$wt index end]
		$wt insert end [string range $t 0 [expr $start-2]]
		formatted_text_purge_all_tags $wt $oldend insert

		# check for begin/end tag
		if { [string range $keyword 0 0] == "/" } {
			# end region
			set keyword [string trimleft $keyword "/"]
			if { [info exists tags($keyword)] == 0 } {
				error "end tag $keyword without beginning"
			}
			$wt tag add $keyword $tags($keyword) insert
			# puts stdout "tag $keyword added from $tags($keyword) to [$wt index insert]"
			unset tags($keyword)
		} else {
			if { [info exists tags($keyword)] == 1 } {
				error "nesting of begin tag $keyword"
			}
			set tags($keyword) [$wt index insert]
			# puts stdout "tag $keyword begins at [$wt index insert]"
		}

		# continue with the rest
		set t [string range $t [expr $end+2] end]
	}
	set oldend [$wt index end]
	$wt insert end $t
	formatted_text_purge_all_tags $wt $oldend insert
	#
	# Disable the text so the user can't mess with it.
	#
	$wt configure -state disabled
}
proc formatted_text_purge_all_tags {w start end} {
	# remote any bogus tags
	# puts stderr "Active tags at $start are [$w tag names $start]"
	foreach tag [$w tag names $start] {
		$w tag remove $tag $start $end
	}
}

proc build_formatted_text {w t} {
	global prog
	if [winfo exists $w] { return }
	toplevel $w
	bind $w <Enter> "focus $w"
	wm withdraw $w
	wm iconname $w "$prog: about"
	wm title $w "$prog: about"

	frame $w.frame -borderwidth 2 -relief raised
	formatted_text $w.frame $t

	button $w.frame.ok -text " Dismiss " -borderwidth 2 -relief raised \
		-command "wm withdraw $w"
	pack $w.frame.ok -pady 6 -padx 6 -anchor e

	pack $w.frame -expand 1 -fill both
}

proc build.help w {
	build_formatted_text $w {
<big>dns_browse help</big>

The main pane shows a DNS hierarchy with indentation.

+/- in the first column indicates a level which can be expanded or contracted.
+? in the second column indicates a level that can be expanded but hasn't been tried yet.

Button-1 expands or contracts a level of the hierarchy.
Button-2 opens a new window showing only the clicked-on item and its children.
Button-3 prints out some debugging information (but you're not supposed to know that :-).

Multiple zones can be downloaded in parallel, but an in-progress zone cannot be contracted.

Record types:
lower-case records are internal:  i)informational, e)rror messages, iz) internal ``zones'' (hierarchy levels), m)essages.

Plans: clicking on www A/CNAMEs links should invoke a real web browser.

Known bugs: dns_tree (invoked to expand sub-levels) can hang due to bogus servers, not all records are supported.  Changing types and re-displaying a level deosn't change what's displayed.  Zones speaking for things outside of their zone don't work correctly.
	}
}

proc build.about w {
	build_formatted_text $w {
<big>dns_browse</big>

Copyright (c) 1997 by John Heidemann (johnh@isi.edu).

A hack in two movements.

The most recent version should be available at http://www.isi.edu/~johnh/SOFTWARE/DNS/index.html.

<small>
This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or any later version.

This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License for more details.

You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
</small>
	}
}

proc show_info {w t} {
	global options
	set wid [widget_to_wid $w]
	if {![info exists options($wid,info_next_id)]} {
		set options($wid,info_next_id) 0
	}
	set id [incr options($wid,info_next_id)]
	set options($wid,info_active_id) $id
	$options($wid,info) configure -text $t
	update
	return $id
}

proc show_timed_info_expire {w id} {
	global options
	set wid [widget_to_wid $w]
	if {$options($wid,info_active_id) == $id} {
		show_info ""
	}
}

# flash a message, then hide it after a while
proc show_timed_info {w time text} {
	global options
	set id [show_info $w $text]
	after [expr 1000*$time] "show_timed_info_expire $w $id"
	update
}

proc widget_to_wid w {
	set second_dot [string first "." [string range $w 1 end]]
	if {$second_dot != -1} {
		set w [string range $w 2 [expr $second_dot]]
	} else {
		set w [string range $w 2 end]
	}
	return $w
}

proc show_all_types wid {
	global maximal_types options
	foreach type $maximal_types {
		set options($wid,show_$type) 1
	}
}

proc build_menu_with_binding {binding_w m label state key ul cmd} {
	$m add command -label $label -state $state -accelerator "^$key" -underline $ul -command $cmd
	bind $binding_w <Meta-$key> $cmd
	bind $binding_w <Control-$key> $cmd
}

proc build_menus {w binding_w dir} {
	global options

	set wid [widget_to_wid $w]

	frame $w.menu -relief groove -bd 2
	pack $w.menu -side top -fill x

	set padx 4

	set mb $w.menu.file
	set m $mb.m
	menubutton $mb -text "File" -menu $m -underline 0 \
		-borderwidth 1 
	menu $m
	build_menu_with_binding $binding_w $m "Open..." disabled o 0 {}
	build_menu_with_binding $binding_w $m "Duplicate" disabled d 0 {}
	build_menu_with_binding $binding_w $m "Close" normal w 0 "after idle {destroy $w}"
	$m add separator
	build_menu_with_binding $binding_w $m "Quit" normal q 0 {exit 0}

	pack $mb -side left -padx $padx

	set mb $w.menu.types
	set m $mb.m
	menubutton $mb -text "Types" -menu $m -underline 0 \
		-borderwidth 1 
	menu $m
	# also UINFO WKS
	global maximal_types
	foreach type $maximal_types {
		$m add checkbutton -label $type -variable options($wid,show_$type)
	}
	$m add separator
	$m add command -label "All" -command "show_all_types $wid"
	pack $mb -side left -padx $padx

	set mb $w.menu.options
	set m $mb.m
	menubutton $mb -text "Options" -menu $m -underline 0 \
		-borderwidth 1 
	menu $m
	$m add checkbutton -label "Hide new iz's" -variable options($wid,hide_new_izs)
	$m add checkbutton -label "Disable safety checks" -variable options($wid,no_safety)
	$m add checkbutton -label "Show only web hosts" -variable options($wid,www_hosts_only)
	pack $mb -side left -padx $padx

	set info $w.menu.info
	set options($wid,info) $info
	label $info -text ""
	pack $info -side left -padx $padx

	set ad $w.menu.ad
	label $ad -text "  dns_browse: $dir  " -relief groove
	pack $ad -side left -padx $padx -expand 1

	set mb $w.menu.help
	set m $mb.m
	menubutton $mb -text "Help" -menu $m -underline 0 \
		-borderwidth 1 
	menu $m
	$m add command -label "Help" -command {toggle_window .help}
	$m add command -label "About dns_browse" -command {toggle_window .about}
	pack $mb -side right -padx $padx
}

proc text_matching_tag {w index head} {
	set depth -1
	foreach tag [$w tag names $index] {
		if [string match "$head*" $tag] {
			set depth [string range $tag [string length $head] end]
			break
		}
	}
	return $depth
}

proc saved_text_insert {w index id} {
	global saved_text
	set t $saved_text($id)

	$w mark set imark $index

	# replay the dump
	set base ""
	foreach {key value index} $t {
		switch -exact $key {
			tagoff {
				if [info exists tags($value)] {
					$w tag add $value $tags($value) imark
					# puts "tagoff $index $value: $tags($value)"
					unset tags($value)
				}
			}
			tagon {
				set tags($value) [$w index imark]
				# puts "tagon $index $value: $tags($value)"
			}
			text {
				$w insert imark $value {}
				# puts "text $index $value"
			}
		}
	}
	# complete any hanging tags
	set search_id [array startsearch tags]
	while {[set i [array nextelement tags $search_id]] != ""} {
		# puts "d-tagoff - $i"
		$w tag add $i $tags($i) imark
	}
	array donesearch tags $search_id
}

proc saved_text_save {w beg end} {
	set t ""
	# first save tags that cross the whole range
	foreach tag [$w tag names $beg] {
		lappend t tagon $tag -
	}
	# then dump the range so we get internal chagnes
	return [concat $t [$w dump $beg $end]]
}

proc swap_line_tag {w linebeg lineend char newtag oldtag} {
	# puts "swap_line_tag: $linebeg $lineend"
	# change the sign of the current line
	# (insert first to preserve tag ranges)
	set len [string length $char]
	$w insert "$linebeg + $len char" $char
	$w delete $linebeg "$linebeg + $len char"
	$w tag remove $oldtag $linebeg $lineend
	$w tag add $newtag $linebeg $lineend
}

proc generate_fqdn {w index} {
	# start on current line, walk backwards
	set fqdn ""
	set beg [$w index "$index lineend"]
	set old_depth [expr [text_matching_tag $w $beg depth]+1]
	while {1} {
		set prev [$w tag prevrange elem $beg]
		if {$prev == ""} {
			break
		}
		set beg [lindex $prev 0]
		set end [lindex $prev 1]
		set new_depth [text_matching_tag $w $beg depth]
		set elem [$w get $beg $end]
		# puts "at $prev: $new_depth $elem ($beg-$end)"
		if {$new_depth >= $old_depth} {
			# only go up, not down or sideways
			continue
		}
		set fqdn "$fqdn.$elem"
		set old_depth $new_depth
	}
	return [string trimleft $fqdn {\.}]
}

proc expand_ns {w beg end base_depth} {
	# first find out the new subdomain
	set fqdn [generate_fqdn $w "$beg lineend"]
	$w mark set imark $end
	catch {
		fill_text $w imark $fqdn $base_depth
	} error
}

proc text_enable w {
	$w configure -state normal
}
proc text_disable w {
	$w configure -state disabled
}

proc act_add_tags {w index tags} {
	# puts "act_add_tags: $w $index $tags"
	text_enable $w
	foreach tag $tags {
		$w tag add $tag "$index linestart" "$index lineend + 1 line linestart"
	}
	text_disable $w
}

proc act_remove_tags {w index tags} {
	text_enable $w
	foreach tag $tags {
		$w tag remove highlight "$index linestart" "$index lineend"
	}
	text_disable $w
}

proc on_target {w index} {
	# puts "on_target $w $index: [$w tag names $index]"
	# sanity
	set on_target [lsearch -exact [$w tag names $index] target]
	$w tag remove target 0.0 end
	if {$on_target == -1} {
		return 0
	}
	return 1
}

proc if_on_target {cmd w index} {
	text_enable $w

	if [on_target $w $index] {
		$cmd $w $index
	}
	
	text_disable $w
}

proc act_plus {w index} {
	text_enable $w

	# find the bounds of the current line
	set linebeg [$w index "$index linestart"]
	set lineend [$w index "$index + 1 line linestart "]
	set depth [text_matching_tag $w $index depth]
	if {$depth == -1} {
		error "act_plus on line without depth"
	}

	# expand it
	set id [text_matching_tag $w $index save]
	if {$id == -1} {
		expand_ns $w $linebeg $lineend $depth
	} else {
		show_info $w "expanding"
		global saved_text
		saved_text_insert $w $lineend $id
		$w tag remove "save$id" $linebeg $lineend
		show_info $w ""
	}

	swap_line_tag $w $linebeg $lineend {- } minus plus
	text_disable $w
}

proc text_<=_depth {w index depth} {
	set beg end
	for {} {$depth >= 0} {incr depth -1} {
		set nextrange [$w tag nextrange "depth$depth" $index]
		if {$nextrange != ""} {
			set nextbeg [lindex $nextrange 0]
			if [$w compare $nextbeg <= $beg] {
				set beg $nextbeg
			}
		}
	}
	return $beg
}

proc act_minus {w index} {
	text_enable $w

	# find the bounds of the current line
	set linebeg [$w index "$index linestart"]
	set lineend [$w index "$index + 1 line linestart"]
	set depth [text_matching_tag $w $index depth]
	if {$depth == -1} {
		error "act_minus on line without depth"
	}

	# find what gets eliminated
	set delbeg [$w index $lineend]
	set delend [text_<=_depth $w $lineend $depth]

	# can't delete active text
	if {[$w tag nextrange expanding $delbeg $delend] != ""} {
		bell
		show_timed_info $w 3 "Cannot compress active trees"
		text_disable $w
		return
	}

	# delete it and save it
	global save_next_id saved_text
	set id [incr save_next_id]
	set saved_text($id) [saved_text_save $w $delbeg $delend]
	$w delete $delbeg $delend
	$w tag add "save$id" $linebeg $lineend

	swap_line_tag $w $linebeg $lineend {+} plus minus
	text_disable $w
}

proc act_new_window {w index} {
	set fqdn [generate_fqdn $w "$index lineend"]
	build_browser $fqdn $w
}

proc build_text w {
	frame $w.text
	set wt "$w.text.text"
	text $wt -relief sunken -bd 2 \
			-xscrollcommand "$w.text.xscroll set" \
			-yscrollcommand "$w.text.yscroll set" \
			-setgrid 1 -height 20 \
			-width 60 \
			-wrap none \
			-font {-*-Courier-Medium-R-*-140-*}
	scrollbar $w.text.xscroll -command "$w.text.text xview" -orient horizontal
	scrollbar $w.text.yscroll -command "$w.text.text yview"
	pack $w.text.xscroll -side bottom -fill x
	pack $w.text.yscroll -side right -fill y
	pack $w.text.text -expand yes -fill both
	pack $w.text -side bottom -expand yes -fill both

	# set up some tags
	$wt tag bind clickable <ButtonPress-1> {act_add_tags %W [%W index {@%x,%y}] target }
	$wt tag bind plus <ButtonRelease-1> {if_on_target act_plus %W [%W index {@%x,%y}] }
	$wt tag bind minus <ButtonRelease-1> {if_on_target act_minus %W [%W index {@%x,%y}] }
	#
	$wt tag bind clickable <ButtonPress-2> {act_add_tags %W [%W index {@%x,%y}] target }
	$wt tag bind plus <ButtonRelease-2> {if_on_target act_new_window %W [%W index {@%x,%y}] }
	$wt tag bind minus <ButtonRelease-2> {if_on_target act_new_window %W [%W index {@%x,%y}] }
	#
	$wt tag bind DEBUG <ButtonRelease-3> {set i [%W index {@%x,%y}]; puts "%W $i [%W tag names $i]"}
	$wt tag configure expanding -font {-*-Courier-Bold-R-*-140-*}
	$wt tag configure target -font {-*-Courier-Bold-R-*-140-*}
#	$wt tag configure ns -font {-*-Courier-Bold-R-*-140-*}

	return $wt
}

proc fill_text_line {w place line base_depth} {
	if {![regexp "^(\t*)(\[^\t\]+)\t+(\[^\t\]+)(.*)$" $line dummy new_tabs type value rest]} {
		error "fill_text_line: '$line' does not follow expected regular expression for records"
	}
	set new_depth [string length $new_tabs]
	set depth [expr $base_depth+$new_depth]
	set wtags {}
	switch -exact $type {
		m  {set ch "! "; set tags message }
		mx {set ch "! "; set tags {message expanding} }
		z  {set ch "  "; set tags {}; set wtags elem }
		NS {set ch "+?"; set tags {clickable plus ns}; set wtags elem }
		iz {set ch "- "; set tags {clickable minus iz}; set wtags elem }
		default {set ch "  "; set tags {}}
	}
	if {$base_depth > 0 && $new_depth == 0 && $type == "z"} {
		return 0
	}
	# puts "$depth $line"
	lappend tags depth$depth DEBUG
	set wtags [concat $tags $wtags]
	set base_tabs [string range "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t" 1 $base_depth]
	$w insert $place "$ch$base_tabs$new_tabs$type\t" $tags \
			$value $wtags \
			"$rest\n" $tags
	return 1
}

proc fill_text_background {w index base_depth f iid} {
	text_enable $w
	global insertion_count
	while {1} {
		gets $f line
		if {$line == ""} {
			if [fblocked $f] {
				# no more input
				text_disable $w
				return
			}
			if [eof $f] {
				break
			}
			# empty line
		}
		incr insertion_count($iid) [fill_text_line $w $index $line $base_depth]
	}

	# eof
	catch { close $f }
	if {$insertion_count($iid) == 0} {
		fill_text_line $w $index "\te\tno-ouptut" $base_depth
	}

	# take down the message and fix the tags
	$w delete iend$iid "iend$iid + 1 line linestart"

	# apply options over ibeg$iid, iend$iid
	global options
	set wid [widget_to_wid $w]
	if {$options($wid,hide_new_izs)} {
		set index ibeg$iid
		while {[$w compare $index < iend$iid] != 0} {
			if {[lsearch -exact [$w tag names $index] iz] != -1} {
				act_minus $w $index
			}
			set index [$w index "$index + 1 line"]
		}
	}

	text_disable $w
}

proc fill_text {w index dir base_depth} {
	global dns_tree insertion_next_id insertion_count options maximal_types
	set iid [incr insertion_next_id]
	set insertion_count($iid) 0

	set wid [widget_to_wid $w]
	set opts ""
	if {$options($wid,no_safety)} {
		set opts "$opts -f"
	}
	if {$options($wid,www_hosts_only)} {
		set opts "$opts -m www"
	}
	foreach type $maximal_types {
		if {$options($wid,show_$type)} {
			set opts "$opts -t $type"
		}
	}
	set f [open "| $dns_tree $opts $dir" r]

	fconfigure $f -blocking false
	# set up insertion marker
	$w mark set ibeg$iid $index
	$w mark gravity ibeg$iid left
	$w mark set iend$iid $index
	$w mark gravity iend$iid left
	fill_text_line $w $index "\tmx\texpanding $dir" $base_depth
	$w mark gravity iend$iid right
	# asynchronously fill in text
	fileevent $f readable "fill_text_background $w iend$iid $base_depth $f $iid"
}

proc build_browser {dir old_w} {
#	set w [toplevel ".$dir"]
	global window_next_id
	set wid [incr window_next_id]
	set w [toplevel ".w$wid"]
	global prog
        wm iconname $w "$prog: $dir"
	wm title $w "$prog: $dir"

	# set options
	global options user_types required_types maximal_types www_hosts_only
	if {$old_w == ""} {
		set options($wid,hide_new_izs) 1
		set options($wid,www_hosts_only) $www_hosts_only
		set options($wid,no_safety) 0
		global maximal_types
		foreach type $maximal_types {
			set options($wid,show_$type) 0
		}
		foreach type $user_types {
			set options($wid,show_$type) 1
		}
		foreach type $required_types {
			set options($wid,show_$type) 1
		}
	} else {
		set old_wid [widget_to_wid $old_w]
		foreach key [array names options] {
			if [string match "$old_wid,*" $key] {
				set part [string range $key [expr [string length $old_wid]+1] end]
				set options($wid,$part) $options($key)
			}
		}
	}

	set tw [build_text $w]
	build_menus $w $tw $dir
	bind $w <Enter> "focus $tw"

	# (set up an insertion mark)
	$tw mark set imark 0.0
	$tw mark gravity imark right

	fill_text $tw imark $dir 0
}

proc main {} {
	global argv
	global save_next_id insertion_next_id window_next_id
	set save_next_id 0
	set insertion_next_id 0
	set window_next_id 0

	# option processing
	global user_types maximal_types default_types www_hosts_only
	if {[llength $argv] < 1} {
		usage
	}
	while {[string index [lindex $argv 0] 0] == "-"} {
		set optc [lindex $argv 0]
		set argv [lrange $argv 1 end]
		if {[llength $argv] > 1} {
			set optarg [lindex $argv 0]
		} else {
			set optarg {}
		}
		switch -exact -- $optc {
			-h	{ usage }
			-t	{
				lappend user_types $optarg
				set argv [lrange $argv 1 end]
			}
			-w	{
				set www_hosts_only 1
			}
			default { usage }
		}
	}
	if {$user_types == "all"} {
		set user_types $maximal_types
	}
	if {$user_types == ""} {
		set user_types $default_types
	}

        if [catch { wm withdraw .} ] {
         puts stderr "DISPLAY variable not set correctly or not running X"
         exit 1
        }


	# argument processing
	foreach name $argv {
		build_browser $name {}
	}
}

main