#!/usr/local/bin/wish -f
#
# tess - tar extraction simplification script
#
# Copyright 1994, Paul E Coad
# The author disclaims all warranties with regard to this software, including
# all implied warranties of merchantability and fitness.  In no event
# shall the author be liable for any special, indirect or consequential
# damages or any damages whatsoever resulting from loss of use, data or
# profits, whether in an action of contract, negligence or other
# tortuous action, arising out of or in connection with the use or
# performance of this software.
# 
# This package is being released under the terms of Larry Wall's
# "Artistic license".

# tess - 2.0 

# This script provides a frontend to the tar command.  Right now
# it provides a method for extracting files from an archive.

# set the following to the directory in which disjoint.tk, fileselect.tcl
# and the tclIndex for tess is located.
set tess_lib /home/pcoad/tcl/tess/library

source $tess_lib/disjoint.tk
source $tess_lib/fileselect.tcl
source $tess_lib/tessdlg.tk

if {[info exists auto_path]} {
	lappend auto_path $tess_lib
} else {
    set auto_path $tess_lib
}

set auto_path "$tk_library $auto_path"
wm title . "tess"

#---------------------------------------------------------------
# default device name (floppy drive 0 on my machine)
# Set default_device for the preferred device if tess is
# called with an argument, it will over-ride the default
# more than one argument and the args will be ignored.
#
set default_device "/dev/fd0"
if {$argc == 1} { set default_device $argv }
#---------------------------------------------------------------

#---------------------------------------------------------------
# defaults for Options menu
# Set each option default as follows: set the default value
# to 1 for on and 0 for off.
set default_owner_perms 1
set default_update_mod_time 0
#---------------------------------------------------------------

#---------------------------------------------------------------
# default temporary file name, set tarlist for the preferred 
# file name
set tarlist "/usr/tmp/tarlist"
#---------------------------------------------------------------

#---------------------------------------------------------------
# set the following to 1 if you have gzip (including gunzip, and 
# either zcat or gzcat) installed.
set have_gzip 1
#---------------------------------------------------------------

#---------------------------------------------------------------
# set the following to 1 if you have a non-standard installation 
# of gzip. 
set have_gzcat 1
#---------------------------------------------------------------

#---------------------------------------------------------------
# set the following to 1 if your version of tar writes everything
# to stderr.
set have_funky_tar 0
#---------------------------------------------------------------

#----------------------------------------------------------------
# Create the main window, consisting of a menu bar a scrolling 
# list and an entry for the device or file from which to extract.
#----------------------------------------------------------------
# create a frame for the menu buttons
frame .menu -relief raised -borderwidth 1

# create a frame for the device entry and label
frame .i

# create the device entry and label
entry .i.device -relief sunken -width 40 
.i.device insert 0 $default_device
button .i.button -text "Device:" -borderwidth 1 -command \
	{fileselect set_device list_set_device "Device:"}

# create the scrolling list
scrollbar .sbar -relief sunken -command ".slist yview"
disjointlistbox .slist -yscroll ".sbar set" -height 12 -width 40 \
			-relief sunken -setgrid 1

# pack the components of the window placing the menubar at the top,
# the device entry and label below that and the scrolling list 
# below those.
pack .menu -side top -fill x
pack .i -side top -fill x
pack .i.button -side left -anchor nw -fill none
pack .i.device -side left -anchor ne -fill x -expand yes
pack .sbar -side right -fill y 
pack .slist -side left -expand yes -fill both 

# set the font for the list to a fixed spacing font
.slist configure -font -adobe-courier-bold-r-normal--*-120-*-*-*-*-*-*

# set the entry to read the archive on Return in the entry
bind .i.device <Return> "tess_read_arc .i.device"

#--------------------------------------------------------------
# The code below creates all the menus, which invoke procedures
# to list and extract files from a tar file or device
#--------------------------------------------------------------
menubutton .menu.button -text "List/Extract" -menu .menu.button.m \
    -underline 0
menu .menu.button.m
.menu.button.m add command -label "List Archive" \
			   -command "tess_read_arc .i.device" -underline 0
.menu.button.m add command -label "Extract All" \
			   -command "tess_extract_all .i.device" -underline 8
.menu.button.m add command -label "Extract Selected" \
			   -command "tess_ext_some .i.device" -underline 0
.menu.button.m add separator
.menu.button.m add command -label "About" -underline 1 -command "tess_about .a"
.menu.button.m add command -label "Quit" -command "destroy ." -underline 0

menubutton .menu.butops -text "Options" -menu .menu.butops.o -underline 0
menu .menu.butops.o

# deal with some of the default values
set own $default_owner_perms 
set modtime $default_update_mod_time 
if { $have_funky_tar } { set redir ">&" } else { set redir ">" }
# always use the gnu zcat if it is available
if { $have_gzip && $have_gzcat } { 
	set ccat gzcat 
} else {
	set ccat zcat
}

.menu.butops.o add check -label "Owner Perms" -variable own
.menu.butops.o add check -label "Update Mod Time" -variable modtime

pack .menu.button .menu.butops -side left

# Set up for keyboard-based menu traversal

bind . <Any-FocusIn> {
    if {("%d" == "NotifyVirtual") && ("%m" == "NotifyNormal")} {
	focus .menu
    }
}
tk_menuBar .menu .menu.button .menu.butops

#-------------------------------------------------------
# procedures for listing and extracting the contents of
# archives
#-------------------------------------------------------

#-----------------------------------------------------------
# tess_read_arc - get listing of the contents of the archive
#
# Args: w	the name of the device entry
#-----------------------------------------------------------
proc tess_read_arc {w} {
global tarlist ccat redir
set dev [$w get]
set compcode 0
set retcode 0
if {[file exists $dev]} {
	# extract a list of the contents into a file
	set dotZ [is_dotZ $dev]
	set dotgz [is_dotgz $dev]
	if {!$dotZ && !$dotgz} {
		# the device is not compressed
		set retcode [eval {
			catch {exec tar tvf $dev $redir $tarlist } compcode}]
	} else {
		# the device is a compressed tar file
		set retcode [catch {exec $ccat $dev | tar tvf - $redir \
			$tarlist} compcode]
	}
	if {$retcode != 0} {
		# open an error dialog with error message
		tessdlg $w.d "tess error" \
			[concat -text [format {{%s}} $compcode] \
			-aspect 250] [format {{%s}} [concat OK {}]] 
	} 

	# clear the list and open the output file
	.slist delete 0 end
	set listfile 0
	set listfile [open $tarlist]

	if {$listfile != 0} {
		# fill the list with the contents of the file
		set i 0
		set max_len 0
		set curr_len 0
		while {[gets $listfile line] >= 0} {
			.slist insert $i $line
			incr i
			set curr_len [string length $line]
			if {$curr_len > $max_len } {
				set max_len $curr_len
			}
		}
		.slist configure -width [expr $max_len + 1]
		close $listfile
		exec rm $tarlist
	} else {
		tessdlg $w.d "tess error" \
			{-text {The temporary file could not be found.} \
			-aspect 250} {OK {}}
	}
} else {
# the device was not found
tessdlg $w.d "tess error" \
	{-text {The requested Device was not found.} -aspect 250} {OK {}}
}}

#-----------------------------------------------------------------------
# tess_get_format - gets the format of the tar options
#
# Args:	baseOps		the base options to be added to the menu options
#-----------------------------------------------------------------------
proc tess_get_format baseOps {
global own modtime
if {$own == 1} { set ow o } else { set ow "" }
if {$modtime == 1} { set mt m } else { set mt "" }
set opts [format "%s%s%s" $ow $mt $baseOps]
return $opts
}

#-------------------------------------------------------
# tess_extract_all - extract all files from the archive
#
# Args: w	the name of the device entry
#-------------------------------------------------------
proc tess_extract_all w {
global own modtime ccat tarlist redir
set dev [$w get]
set compcode 0
if {[file exists $dev]} {
	# set the extraction options
	set opts [tess_get_format xvf]
	set dotZ [is_dotZ $dev]
	set dotgz [is_dotgz $dev]
	if {!$dotZ && !$dotgz} {
		set retcode [eval {
			catch {exec tar $opts $dev $redir $tarlist} compcode}]
	} else {	
		# the device is a compressed tar file
		set retcode [eval { \
				catch {exec $ccat $dev | tar $opts - $redir \
				$tarlist} compcode}]
	}
	if {$retcode != 0} {
		# open an error dialog with error message
		tessdlg $w.f "tess error" \
			[concat -text [format {{%s}} $compcode] \
			-aspect 250] [format {{%s}} [concat OK {}]] 
		set fsize [file size $tarlist]
		if {$fsize > 0} {
			# open a dialog indicating that at least some of
			# the files were read
			tess_list_files $w
		}
	} else { 
		# open dialog indicating that the files were read
		tess_list_files $w
	}
} else {
# the device was not found
tessdlg $w.d "tess error" \
	{-text {The requested Device was not found.} -aspect 250} {OK {}}
}
}

#-------------------------------------------------------
# tess_ext_some - extract the selected files from the archive
#
# Args: w	the name of the device entry
#-------------------------------------------------------
proc tess_ext_some w {
global own modtime tarlist ccat redir
set dev [$w get]
set compcode 0
if {[file exists $dev]} {
	# find the selected items in the list
	set selected [.slist curselection]
	if {[llength $selected] != 0} {
		set flist ""
		foreach i $selected {
			set tlist [.slist get $i]
			#set flist [concat $flist [lindex $tlist 6]]
			set tlistl [expr [llength $tlist] -1]
			set flist [concat $flist [lindex $tlist $tlistl]]
		}
		# set the extraction options and prepare for the read
		set opts [tess_get_format xvf]
		set dotZ [is_dotZ $dev]
		set dotgz [is_dotgz $dev]
		if {!$dotZ && !$dotgz} {
			set retcode [catch { \
				eval exec tar $opts $dev $flist $redir \
					$tarlist} compcode]
		} else {
			# the device is a compressed tar file
			set retcode [catch {
			    eval exec $ccat $dev | tar $opts - $flist $redir \
					$tarlist} compcode]
		}
		if {$retcode != 0} {
			# open an error dialog with error message
			tessdlg $w.e "tess error" \
				[concat -text [format {{%s}} $compcode] \
				-aspect 250] [format {{%s}} [concat OK {}]] 
			set fsize [file size $tarlist]
			if {$fsize > 0} {
				# open a dialog indicating that at least some 
				# of the files were read
				tess_list_files $w
			}
		} else { 
			# open dialog indicating that the files were read
			tess_list_files $w
		}
	} else {
		# open error dialog box - no files were selected
		tessdlg $w.d "tess error" \
			{-text {No files were selected.} -aspect 250} {OK {}}
	}
} else {
# the device was not found
tessdlg $w.d "tess error" \
	{-text {The requested Device  ar not found.} -aspect 250} {OK {}}
}
}

#---------------------------------------------------------------------
# tess_list_files lists the extracted files in a scrolling list in a 
#                 window.
#
# Args: w	Name to use for new top-level window.
#---------------------------------------------------------------------
proc tess_list_files {w} {
global tarlist
catch {destroy $w.d}
toplevel $w.d
wm title $w.d "tess - extracted files"
wm geometry $w.d +300+300

frame $w.d.frm
scrollbar $w.d.frm.sbar -relief sunken -command "$w.d.frm.slist yview"
listbox $w.d.frm.slist -yscroll "$w.d.frm.sbar set" -relief sunken -setgrid 1 
button $w.d.frm.butt -text "Done" -borderwidth 1 -command "destroy $w.d" 

# clear out any crap that might be in the list
$w.d.frm.slist delete 0 end

# open the temporary file to read the files extracted
set fp [open $tarlist]

set j 0
set max_len 0
set cur_len 0
# get each line from the file, strip the leading x and place in the list
while {[gets $fp line] >= 0} {
	$w.d.frm.slist insert $j [string trimleft $line x]
	incr j
	set cur_len [string length $line]
	if {$cur_len > $max_len } {
		set max_len $cur_len
	}
}
pack $w.d.frm -fill both -expand yes
pack $w.d.frm.butt -side bottom -fill x 
pack $w.d.frm.slist -side left -fill both -expand yes 
pack $w.d.frm.sbar -side right -fill y 

$w.d.frm.slist configure -geometry [expr $max_len + 1]x10 -exportselection no

# set the font for the list to a fixed spacing font
$w.d.frm.slist configure -font -adobe-courier-bold-r-normal--*-120-*-*-*-*-*-*
close $fp
exec rm $tarlist
}

#---------------------------------------------------------------------
# tess_about shows the legal stuff in a window
#
# Args: w	Name to use for new top-level window.
#---------------------------------------------------------------------
proc tess_about w {
catch {destroy $w}
toplevel $w -class Dialog

# set up window
wm title $w "tess - about"
wm iconname $w "tess - about"
wm geometry $w +300+300

# create frames for messages and done button
frame $w.frame_top -relief raised -border 1
frame $w.frame_bot -relief raised -border 1
pack $w.frame_top -side top -fill both
pack $w.frame_bot -side bottom -fill both

# create messages in top frame
message $w.frame_top.title -justify center -width 300 \
  -text "tess - tar extraction simplification script"
message $w.frame_top.copyright -justify center -width 300 -text \
	"Copyright 1994, Paul E Coad"
message $w.frame_top.disclaim -justify center -width 320 -text "The author disclaims all warranties with regard to this software, including all implied warranties of merchantability and fitness.  In no event shall the author be liable for any special, indirect or consequential damages or any damages whatsoever resulting from loss of use, data or profits, whether in an action of contract, negligence or other tortuous action, arising out of or in connection with the use or performance of this software."
message $w.frame_top.release -justify center -width 300 -text "This package is being released under the terms of Larry Wall's Artistic license."

# create button in bottom frame 
button $w.frame_bot.done -text "Done" -command "destroy $w" 

# pack them up and put them out
pack $w.frame_top.title -side top -fill both -pady 8
pack $w.frame_top.copyright -side top 
pack $w.frame_top.disclaim -side top 
pack $w.frame_top.release -side top -pady 3
pack $w.frame_bot.done -side bottom -fill both

}

#---------------------------------------------------------------------
# is_dotZ determines if a string ends in ".Z" and is therefore 
#	  assumed to be compressed.  If the global variable have_gzip
#	  is set to 1 files ending in ".taz" or ".taZ" will be recognized
#	  as being compressed tar files.
#
# Args: str	The string to examine
#---------------------------------------------------------------------
proc is_dotZ str {
global have_gzip
set last_dot_index [string last . $str]
set Z_index [string last Z $str]
set taZ_index [string last taZ $str]
set taz_index [string last taz $str]

# check the the placement of the suffix ensure that it is the last
# in the string and directly follows a dot(.).
set str_len [string length $str]
if { $Z_index != -1 && \
     [expr ($last_dot_index + 1) == $Z_index] && \
     [expr ($Z_index + 1) == $str_len] } { 
	set compressed 1
} elseif { $have_gzip &&
    $taZ_index != -1 && \
    [expr ($last_dot_index + 1) == $taZ_index] && \
    [expr ($taZ_index + 3) == $str_len] } {
	set compressed 1
} elseif { $have_gzip &&
    $taz_index != -1 && \
    [expr ($last_dot_index + 1) == $taz_index] && \
    [expr ($taz_index + 3) == $str_len] } {
	set compressed 1
} else {
	set compressed 0
}
return $compressed
}

#---------------------------------------------------------------------
# is_dotgz determines if a string ends in ".gz" or ".tgz" and is therefore 
#	  assumed to be zipped with the GNU zip program.  
#
# Args: str	The string to examine
#---------------------------------------------------------------------
proc is_dotgz str {
set last_dot_index [string last . $str]
set gz_index [string last gz $str]
set offset 2
set tgz_index [string last tgz $str]
if {[expr ($tgz_index + 1) == $gz_index]} { 
	set gz_index $tgz_index
	set offset 3
}

# check the the placement of the suffix ensure that it is the last
# in the string and directly follows a dot(.).
set str_len [string length $str]
if { $gz_index == -1 || \
     [expr ($last_dot_index + 1) != $gz_index] || \
     [expr ($gz_index + $offset) != $str_len] } { 
	set gzipped 0
} else {
	set gzipped 1
}
return $gzipped
}

#---------------------------------------------------------------------
# set_device sets the value in the device entry and serves as a 
#	     command for fileselect (by Mario Jorge Silva) to execute 
#	     when a file is selected.  set_device also clears the 
#	     scrolling list.  (this proc is a hack and should be
#	     generalized to require no globals)
#
# Args: dev_name 	the name of the file to select.
#---------------------------------------------------------------------
proc set_device dev_name {
global .i.device .slist

.i.device delete 0 end
.i.device insert 0 $dev_name
.slist delete 0 end
}

#---------------------------------------------------------------------
# list set_device sets the value in the device entry and serves as a 
#	     command for fileselect (by Mario Jorge Silva) to execute 
#	     when a file is selected.  set_device also clears the 
#	     scrolling list and lists the contents of the passed file.
#	     (this proc is a hack and should be generalized to require 
#	     no globals)
#
# Args: dev_name 	the name of the file to select.
#---------------------------------------------------------------------
proc list_set_device dev_name {
global .i.device .slist

.i.device delete 0 end
.i.device insert 0 $dev_name
.slist delete 0 end
tess_read_arc .i.device
}
