#!/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 authorbe 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 licence".

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

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 }
#---------------------------------------------------------------

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

#----------------------------------------------------------------
# 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 
label .i.label -text Device:
.i.device insert 0 $default_device

# create the scrolling list
scrollbar .sbar -relief sunken -command ".slist yview"
listbox .slist -yscroll ".sbar set" -relief sunken -setgrid 1

# pack the components of the window puting 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.label -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 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 command -label "Quit" -command "destroy ." -underline 0

menubutton .menu.butops -text "Options" -menu .menu.butops.o -underline 0
menu .menu.butops.o
.menu.butops.o add check -label "Owner Perms" -variable own
.menu.butops.o add check -label "Update Mod Time" -variable modtime
set zcatIsGzcat 0
.menu.butops.o add check -label "zcat is gzcat" -variable zcatIsGzcat
.menu.butops.o invoke 0

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
set dev [$w get]
if {[file exists $dev]} {
	# extract a list of the contents into a file
	set compcode 0
	set retcode 0
	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 > $tarlist } compcode}]
	} else {
		if {$dotgz} {set ccat gzcat} else {set ccat zcat}
		# the device is a compressed tar file
		set retcode [catch {exec $ccat $dev | tar tvf - > \
			$tarlist} compcode]
	}
	if {$retcode != 0} {
		# open an error dialog with error message
		tessdlg $w.d "tess error1" \
			[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
		while {[gets $listfile line] >= 0} {
			.slist insert $i $line
			incr i
		}
		close $listfile
		exec rm $tarlist
	} else {
		tessdlg $w.d "tess error2" \
			{-text {The temporary file could not be found.} \
			-aspect 250} {OK {}}
	}
} else {
# the device was not found
tessdlg $w.d "tess error3" \
	{-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 zcatIsGzcat tarlist
set dev [$w get]
if {[file exists $dev]} {
	# set the extraction options
	set opts [tess_get_format xvf]
	set compcode 0
	set dotZ [is_dotZ $dev]
	set dotgz [is_dotgz $dev]
	if {!$dotZ && !$dotgz} {
		set retcode [eval {
			catch {exec tar $opts $dev > $tarlist} compcode}]
	} else {	
		if {$dotgz && $zcatIsGzcat == 0} {
			set ccat gzcat} else {set ccat zcat}
		# the device is a compressed tar file
		set retcode [eval {catch {exec $ccat $dev | tar $opts - > \
				$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 atleast 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
set dev [$w get]
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 the extraction options and prepare for the read
		set opts [tess_get_format xvf]
		set compcode 0
		set dotZ [is_dotZ $dev]
		set dotgz [is_dotgz $dev]
		if {!$dotZ && !$dotgz} {
			set retcode [catch {eval exec tar $opts $dev $flist > \
					$tarlist} compcode]
		} else {
			if {$dotgz} {set ccat gzcat} else {set ccat zcat}
			# the device is a compressed tar file
			set retcode [catch {
				eval exec $ccat $dev | tar $opts - $flist > \
					$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 atleast 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" -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
# 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
}
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 
close $fp
exec rm $tarlist
}

#---------------------------------------------------------------------
# tessdlg Create a dialog box with a message and any number of 
#	  buttons at the bottom.
#
# Arguments:
#    w -        Name to use for new top-level window.
#    wTitle	Title of the window
#    msgArgs -  List of arguments to use when creating the message of the
#               dialog box (e.g. text, justifcation, etc.)
#    list -     A two-element list that describes one of the buttons that
#               will appear at the bottom of the dialog.  The first element
#               gives the text to be displayed in the button and the second
#               gives the command to be invoked when the button is invoked.
#
# Note: borrowed and modified mkDialog.tcl from tk distribution demos
#       due credit should be given to Mr. John Ousterhout.
#---------------------------------------------------------------------
proc tessdlg {w wTitle msgArgs args} {
    catch {destroy $w}
    toplevel $w -class Dialog
    wm title $w $wTitle
    wm iconname $w $wTitle
    wm geometry $w +300+300
    # Create two frames in the main window. The top frame will hold the
    # message and the bottom one will hold the buttons.  Arrange them
    # one above the other, with any extra vertical space split between
    # them.

    frame $w.top -relief raised -border 1
    frame $w.bot -relief raised -border 1
    pack $w.top $w.bot -side top -fill both -expand yes
    # Create the message widget and arrange for it to be centered in the
    # top frame.

    eval message $w.top.msg -justify center \
            -font -Adobe-times-medium-r-normal--*-180* $msgArgs
    pack $w.top.msg -side top -expand yes -padx 3 -pady 3

    # Create as many buttons as needed and arrange them from left to right
    # in the bottom frame.  Embed the left button in an additional sunken
    # frame to indicate that it is the default button, and arrange for that
    # button to be invoked as the default action for clicks and returns in
    # the dialog.

    if {[llength $args] > 0} {
        set arg [lindex $args 0]
        frame $w.bot.0 -relief sunken -border 1
        pack $w.bot.0 -side left -expand yes -padx 10 -pady 10
        button $w.bot.0.button -text [lindex $arg 0] \
                -command "[lindex $arg 1]; destroy $w"
        pack $w.bot.0.button -expand yes -padx 6 -pady 6
        bind $w <Return> "[lindex $arg 1]; destroy $w"
        focus $w
        set i 1
        foreach arg [lrange $args 1 end] {
            button $w.bot.$i -text [lindex $arg 0] \
                    -command "[lindex $arg 1]; destroy $w"
            pack $w.bot.$i -side left -expand yes -padx 10
            set i [expr $i+1]
        }
    }
    bind $w <Any-Enter> [list focus $w]
    focus $w
}

#---------------------------------------------------------------------
# is_dotZ determines if a string ends in ".Z" and is therefore 
#	  assumed to be compressed.
#
# Args: str	The string to examine
#---------------------------------------------------------------------
proc is_dotZ str {
set last_dot_index [string last . $str]
set Z_index [string last Z $str]
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 0
} else {
	set compressed 1
}
return $compressed
}

#---------------------------------------------------------------------
# is_dotgz determines if a string ends in ".gz" 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 str_len [string length $str]
if { $gz_index == -1 || \
     [expr ($last_dot_index + 1) != $gz_index] || \
     [expr ($gz_index + 2) != $str_len] } { 
	set gzipped 0
} else {
	set gzipped 1
}
return $gzipped
}
