#!/bin/sh
# the next line restarts using wish \
exec wish "$0" "$@"       

# TkTapeTool - simple front-end for GNU tar
# Version 0.23, 2001-05-04
# (Version 0.22, 2000-09-07)
#
# Copyright (C) 2000-2001 by T.Sato <VEF00200@nifty.ne.jp>
#
# http://member.nifty.ne.jp/tsato/tkdeskset/
#
# 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.

# Usage:
#   tktapetool [ -readonly | -writeonly ] [ files... ]

set program_name "TkTapeTool"
set title "$program_name  (Version 0.23)"

wm title . $title
wm iconname . $program_name

set org_dir [ pwd ]
set tktapetoolrc "$env(HOME)/.tktapetoolrc"
set tmpfile "/tmp/tktapetool.[pid]"
set tar_command "tar"
set mt_command "mt"
set fdformat "fdformat"
set xterm "xterm"

set ps_l "ps -aef"
if [ catch { eval exec $ps_l | head -1 | egrep ' PID +PPID ' } ] {
    set ps_l "ps -axl"
}

set tape_devices {}
foreach dev [ concat \
	[ lsort [ glob {/dev/st[0-9]} {/dev/ht[0-9]} {/dev/rmt/*} ] ] \
	[ lsort [ glob {/dev/fd[0-9]*} ] ] ] {
    if { [ file readable $dev ] && [ file writable $dev ] } {
	lappend tape_devices $dev
    }
}
lappend tape_devices "Other"

set debug 0
set child_pid 0
set killed 0

set read_ops "normal"
set write_ops "normal"

# Set default parameters.
#
set lang "C"
if { ! [ catch { kanji code "abc" } ] } {
    catch { set lang $env(LANG) }
    catch { set lang $env(LC_ALL) }
    catch { set lang $env(LC_MESSAGES) }
}

proc set_default {} {
    global device_entry device opt
    global org_dir base_dir

    set device_entry ""
    set device ""
    catch { set device_entry $env(TAPE) }
    if [ winfo exists .props ] { props_device_select $device_entry }

    set opt(compress)        ""
    set opt(format)          ""
    set opt(keep_old_files)  0
    set opt(unlink_first)    0
    set opt(ignore_zeros)    0
    set opt(same_permission) 0
    set opt(dereference)     0
    set opt(one_file_system) 0
    set opt(absolute_paths)  1
    set opt(multi_volume)    0
    set opt(verbose)         1

    set base_dir $org_dir
}
set_default

catch {
    source $tktapetoolrc
}

# For Japanese locale, translate messages to Japanese.
#
proc gettext msg {
    global lang

    if [ regexp {^ja_|^japanese|^ja$} $lang junk ] {
	switch -glob $msg {
	    "Read" \
		    { return "読み取り" }
	    "Continue" \
		    { return "継続" }
	    "List..." \
		    { return "リスト..." }
	    "Read Selected Files" \
		    { return "選択したファイルの読み取り" }
	    "Read Entier Tape" \
		    { return "全テープの読み取り" }
	    "Write" \
		    { return "書き込み" }
	    "Tape" \
		    { return "テープ" }
	    "Floppy" \
		    { return "フロッピー" }
	    "Offline" \
		    { return "オフライン" }
	    "Rewind" \
		    { return "巻き戻し" }
	    "Retension" \
		    { return "巻き直し" }
	    "offline" \
		    { return "オフライン" }
	    "rewind" \
		    { return "巻き戻し" }
	    "retension" \
		    { return "巻き直し" }
	    "Format Floppy" \
		    { return "フロッピーのフォーマット" }
	    "Property..." \
		    { return "プロパティ..." }
	    "Base Directory:" \
		    { return "ベース・ディレクトリ:" }
	    "Browse..." \
		    { return "ブラウズ..." }
	    "Files or Directories to Write:" \
		    { return "書き込むべきファイルやディレクトリ:" }
	    "Listing files in %s..." \
		    { return "ファイルのリストの取得 (%s)..." }
	    "Extracting selected files from %s..." \
		    { return "選択されたファイルを %s から読み取り中..." }
	    "Extracting all files from %s..." \
		    { return "全てのファイルを %s から読み取り中..." }
	    "Writing files to %s..." \
		    { return "ファイルを %s へ書き込み中..." }
	    "Formatting floppy on %s..." \
		    { return "フロッピーのフォーマット..." }
	    "Done." \
		    { return "完了" }
	    "Done (%s entries)" \
		    { return "完了 (%s個の項目)" }
	    "Aborted" \
		    { return "処理を中止しました" }
	    "Device:" \
		    { return "デバイス:" }
	    "Other" \
		    { return "その他" }
	    "Remote..." \
		    { return "リモート..." }
	    "When Reading:" \
		    { return "読み取り:" }
	    "When Writing:" \
		    { return "書き込み:" }
	    "Don't overwrite existing files when extracting" \
		    { return "読み取りに際して既存のファイルを上書きしない" }
	    "Remove old file prior to extracting over it" \
		    { return "既存のファイルに上書きする前に古いものを削除する" }
	    "Extract all protection information" \
		    { return "全ての保護情報を抽出する" }
	    "Ignore blocks of zeros in archive" \
		    { return "アーカイブ中のゼロのブロックを無視する" }
	    "Dereference symbolic-links" \
		    { return "シンボリック・リンク先のファイルをバックアップする" }
	    "Don't backup files in the other file system" \
		    { return "他のファイル・システムのファイルをバックアップしない" }
	    "Format:" \
		    { return "フォーマット:" }
	    "Don't strip leading `/'s from file names" \
		    { return "ファイル名の前の `/' を取り除かない" }
	    "Another Options:" \
		    { return "その他のオプション:" }
	    "Compress:" \
		    { return "圧縮:" }
	    "none" \
		    { return "なし" }
	    "compress" \
		    { return "compress" }
	    "gzip" \
		    { return "gzip" }
	    "Multi-volume archive" \
		    { return "マルチ・ボリューム・アーカイブ" }
	    "Display file list when processing" \
		    { return "処理に際してファイルのリストを表示する" }
	    "Close" \
		    { return "閉じる" }
	    "Save Settings" \
		    { return "設定を保存する" }
	    "Set to Default Settings" \
		    { return "デフォルトの設定に戻す" }
	    "Set" \
		    { return "設定" }
	    "Cancel" \
		    { return "取り消し" }
	    "Host:" \
		    { return "ホスト:" }
	    "User:" \
		    { return "ユーザー:" }
	    "Error!" \
		    { return "エラー！" }
	    "Current Directory:" \
		    { return "現在のディレクトリ:" }
	    "Files or directories to write are*" \
		    { return "書き込むべき ファイルや ディレクトリが 指定されて いません" }
	    "Please insert a new medium in %s to write remaining files*" \
		    { return "残りの ファイルを 書き込むために\
		    %s に 新しい メディアを 挿入し、\
		    「継続」を クリックして 下さい。" }
	    "Please insert medium of the next volume in %s to list remaining files*" \
		    { return "残りの ファイルの リストを 取得するために\
		    %s に 次のボリュームの メディアを 挿入し、\
		    「継続」を クリックして 下さい。" }
	    "Please insert medium of the next volume in %s to extract remaining files*" \
		    { return "残りの ファイルを 読み取るために\
		    %s に 次のボリュームの メディアを 挿入し、\
		    「継続」を クリックして 下さい。" }
	    "Please insert medium of the next volume in %s to process remaining files*" \
		    { return "残りの ファイルを 処理するために\
		    %s に 次のボリュームの メディアを 挿入し、\
		    「継続」を クリックして 下さい。" }
	    "Do you want to abort processing on %s?" \
		    { return "%s に対する 処理を 中止しますか？" }
	    "Child process exists*" \
		    { return "子プロセスが存在しています。\
		    \n本当に TkTapeTool を終了しますか？" }
	    "No files are selected on the file list*" \
		    { return "ファイルのリストの上で ファイルが 選択されていません。\
		    \n読み取りたい ファイルを １つ以上 選択して やり直して 下さい。" }
	    "No file list*"\
		    { return "ファイルの リストが ありません。\
		    \n「リスト...」 を選択して ファイルのリストを 取得し、\
		    そのリストの上で ファイルを 選択して 下さい。" }
	    "Device name is not specified.*" \
		    { return "デバイス名が 指定されていません。\
		    \nプロパティ・パネルで デバイスを 選択して やり直して 下さい。" }
	    "To use remote tape,*" \
		    { return "リモートの テープを 使用する ためには、\
		    その ホスト名 (もしくは IP アドレス) と\
		    デバイス名を 指定する 必要が あります。" }
	    "No such directory: %s" \
		    { return "そのディレクトリは存在しません: %s" }
	    default \
		    { return $msg }
        }
    }
    return $msg
}

# Save current setting of properties to $HOME/.tktapetoolrc.
#
proc save_props {} {
    global tktapetoolrc device_entry opt

    set f [ open "$tktapetoolrc" w ]
    puts $f "set device_entry \"$device_entry\""
    foreach s [ array names opt ] {
	puts $f "set opt($s) $opt($s)"
    }
    close $f
}

# Change directory to $base_dir
#
proc change_dir dir {
    global org_dir base_dir debug

    if { $dir == "" } { set dir "/" }
    if { $debug } { puts "change_dir($dir)" }
    cd $org_dir
    if { ! [ file isdirectory $dir ] } {
        show_error [ format [ gettext "No such directory: %s" ] $dir ]
        return 0;
    }
    cd $dir
    return 1
}

# Execute specified command in background.
#
proc execute_command cmd {
    global debug tmpfile child_pid

    if { ! $debug } { append cmd " 2> $tmpfile.err" }
    if { $debug } { puts "Exec: $cmd" }
    set child_pid [ eval exec "$cmd &" ]
}

# Return PID of the parent process.
# If the process is not exists, returns 0.
#
proc ppid pid {
    global ps_l debug

    set result 0
    set f [ open "| $ps_l" r ]
    if { 0 <= [ gets $f line ] } {
	set pid_inx [ lsearch $line "PID" ];
	set ppid_inx [ lsearch $line "PPID" ];
	if { $pid_inx < 0 || $ppid_inx < 0 } {
	    error "\"$ps_l\" must returns both PID and PPID."
	}
	while { 0 <= [ gets $f line ] } {
	    if { [ lindex $line $pid_inx ] == $pid } {
		set result [ lindex $line $ppid_inx ]
		break
	    }
	}
    }
    catch { close $f }
    if { $debug } { puts "ppid($pid) = $result" }

    return $result
}

# Returns list of all descendants processes.
#
proc list_children pid {
    global ps_l debug

    if { $pid == {} } { set pid [ pid ] }
    set list ""
    set f [ open "| $ps_l" r ]
    if { 0 <= [ gets $f line ] } {
	set pid_inx [ lsearch $line "PID" ];
	set ppid_inx [ lsearch $line "PPID" ];
	if { $pid_inx < 0 || $ppid_inx < 0 } {
	    error "\"$ps_l\" must returns both PID and PPID."
	}
	while { 0 <= [ gets $f line ] } {
	    if { [ lindex $line $ppid_inx ] == $pid } {
		set n [ lindex $line $pid_inx ]
		if { $n != [ pid $f ] } {
		    set list "$list $n [ list_children $n ]"
		}
	    }
	}
    }
    catch { close $f }
    if { $debug } { puts "list_children($pid) = $list" }

    return $list
}

# Kill all descendants processes.
#
proc kill_children { { opt "normal" } } {
    global tmpfile killed

    set pids [ list_children {} ]
    if { $pids != "" } {
	catch { eval exec kill -KILL $pids }
	after 500
	if { $opt != "normal" } {
	    set killed 1
	    .top.message configure -text [ gettext "Aborted" ]
	}
    }

    catch { eval file delete [ glob $tmpfile.* ] }
}

# Get option characters for GNU tar.
# 
proc get_tar_options mode {
    global opt device_entry

    set s ""
    if { $mode == "x" } {
	if { $opt(keep_old_files) } { append s "k" }
	if { $opt(unlink_first) } { append s "U" }
	if { $opt(ignore_zeros) } { append s "i" }
	if { $opt(same_permission) } { append s "p" }
    } elseif { $mode == "c" } {
	if { $opt(dereference) } { append s "h" }
	if { $opt(one_file_system) } { append s "l" }
	if { $opt(absolute_paths) } { append s "P" }
    }
    if { $opt(verbose) } { append s "v" }
    if { $opt(compress) == "compress" } { set s "Z" }
    if { $opt(compress) == "gzip" } { set s "z" }

    if { $s != "" } { set s "-$s" }
    if { $mode == "c" } {
	switch $opt(format) {
	    "old" { append s " --old-archive" }
	    "posix" { append s " --posix" }
	}
    }
    if { $opt(multi_volume) } {
	set x [ expr [ winfo rootx . ] + [ winfo width . ] / 3 ]
	set y [ expr [ winfo rooty . ] + [ winfo height . ] / 3 ]
	append s " --info-script=tktapetool\\\
		-q$mode,$device_entry\\ -geometry\\ +$x+$y"
    }

    return $s
}

# Invoke window to show temporary file list.
# This window will be closed automatically after operation.
#
proc show_progress {} {
    global opt tmpfile xterm xterm_pid

    if { $opt(verbose) } {
	exec echo > $tmpfile.list
	set xterm_pid [ exec nice $xterm -title "TkTapeTool - Progress" \
		-e tail -f $tmpfile.list & ]
	after 500
    }
}

# Get file list on the tape.
#
proc list_tape {} {
    global tar_command device_entry tmpfile
    global killed

    set killed 0

    .top.message configure \
	    -text [ format [ gettext "Listing files in %s..." ] \
	    $device_entry ]
    if [ winfo exists .error ] { destroy .error }
    if [ winfo exists .list ] { destroy .list }

    if { $device_entry == "" } {
        show_error "no device"
        return
    }

    show_progress
    set cmd "$tar_command -t [ get_tar_options "t" ] \
            -f $device_entry > $tmpfile.list"
    execute_command $cmd
    check_process list
}

# Extract files selected on the file list.
#
proc read_selected {} {
    global opt list_verbose tar_command device_entry tmpfile base_dir
    global killed

    set killed 0

    .top.message configure \
	    -text [ format [ gettext "Extracting selected files from %s..." ] \
	    $device_entry ]
    if [ winfo exists .error ] { destroy .error }

    if { $device_entry == "" } {
        show_error "no device"
        return
    }
    if { ! [ change_dir $base_dir ] } { return }

    if [ winfo exists .list ] {
        set selected 0
        set f [ open $tmpfile.sel w ]
        foreach i [ .list.list curselection ] {
            set selected 1
            set s1 [ .list.list get $i ]
            if { $list_verbose } { regexp {([^ ]+)$} $s1 s1 }
            puts $f $s1
        }
        close $f
        if { $selected } {
            show_progress
            set cmd "$tar_command -x [ get_tar_options "x" ] \
                    -f $device_entry -T $tmpfile.sel > $tmpfile.list"
	    execute_command $cmd
	    check_process
        } else {
            show_error "No files are selected on the file list.\
		    \nPlease select one or more files to be extracted on the file list\
		    and try again."
        }
    } else {
        show_error "No file list.\
		\nPlease use \"List...\" to get file list\
		and select files on the list."
    }
}

# Extract all files in the tape.
#
proc read_entier_tape {} {
    global opt tar_command device_entry tmpfile base_dir
    global killed

    set killed 0

    .top.message configure \
	    -text [ format [ gettext "Extracting all files from %s..." ] \
	    $device_entry ]
    if [ winfo exists .error ] { destroy .error }

    if { $device_entry == "" } {
        show_error "no device"
        return
    }
    if { ! [ change_dir $base_dir ] } { return }

    show_progress
    set cmd "$tar_command -x [ get_tar_options "x" ] \
            -f $device_entry > $tmpfile.list"
    execute_command $cmd
    check_process
}

# Backup files to the tape.
#
proc write_tape {} {
    global opt tar_command device_entry tmpfile base_dir
    global killed

    set killed 0

    .top.message configure \
	    -text [ format [ gettext "Writing files to %s..." ] \
	    $device_entry ]
    if [ winfo exists .error ] { destroy .error }
    if [ winfo exists .list ] { destroy .list }

    if { $device_entry == "" } {
        show_error "no device"
        return
    }
    if { ! [ change_dir $base_dir ] } { return }

    regsub -all "\n" [ .top.ftw_entry get 0.0 end ] " " files
    regsub {/$} $base_dir "" s

    regsub -all {^|$} $files " " files
    if { $base_dir != "" } {
	regsub -all " ${s}/ " $files " ./ " files
	regsub -all " ${s}/" $files " " files
	if { $s != "" } {
	    regsub -all " ${s} " $files " ./ " files
	}
    }
    regsub {^ +} $files "" files
    regsub { +$} $files "" files
    regsub -all { +} $files " " files

    if { $files == "" } {
        show_error "Files or directories to write are not specified"
    } else {
	show_progress
	set cmd "$tar_command -c [ get_tar_options "c" ] \
		-f $device_entry $files > $tmpfile.list"
	execute_command $cmd
        check_process
    }
}

# Some tape operations.
#
proc mt_ops op {
    global mt_command device_entry
    global killed

    set killed 0
    kill_children

    .top.message configure -text "[ gettext $op ]..."

    if [ winfo exists .error ] { destroy .error }

    if { $device_entry == "" } {
        show_error "no device"
        return
    }

    .top.mt configure -state disabled

    set cmd "$mt_command -f $device_entry $op"
    execute_command $cmd
    check_process
}

# Format floppy disk
#
proc fdd_format {} {
    global fdformat device_entry tmpfile
    global killed

    set killed 0
    kill_children

    .top.message configure \
	    -text [ format [ gettext "Formatting floppy on %s..." ] \
	    $device_entry ]
    if [ winfo exists .error ] { destroy .error }

    if { $device_entry == "" } {
        show_error "no device"
        return
    }

    .top.mt configure -state disabled

    show_progress
    exec echo "--- Formatting floppy disk: $device_entry\n" > $tmpfile.list
    set cmd "$fdformat $device_entry >> $tmpfile.list"
    execute_command $cmd
    check_process
}

# Check if child process (tar command) is terminated,
# and open File List window if necessary.
# If error message is written by the child process,
# it will also reported.
#
proc check_process { { list "nolist" } { first 1 } } {
    global opt list_verbose child_pid tmpfile killed
    global err_size read_ops write_ops

    if { $first } {
	set err_size 0
	set found 1
        .top.list configure -state disabled
        .top.readbutton configure -state disabled
        .top.writebutton configure -state disabled
    } else {
	set found [ ppid $child_pid ]
    }

    if { [ file readable $tmpfile.err ] \
	    && [ file size $tmpfile.err ] != $err_size } {
	set err_size [ file size $tmpfile.err ]
	set s1 ""
	set f [ open $tmpfile.err r ]
	while { 0 <= [ gets $f line ] } {
	    if { $s1 != "" } { append s1 \n }
	    append s1 $line
	    if { 3000 < [ string length $s1 ] } {
		append s1 "\n..."
		break
	    }
	}
	close $f
	show_error $s1 . 1
    }

    if { $found } {
	after 1000 "check_process $list 0"
    } else {
	if { ! $killed } {
	    if { ! [ winfo exists .error ] } {
		.top.message configure -text [ gettext "Done." ]
	    }
	    if { [ file readable $tmpfile.list ] \
		    && [ file size $tmpfile.list ] != "0" } {
		set lines 0
		set f [ open $tmpfile.list r ]
		while { 0 <= [ gets $f line ] } {
		    if { $lines == 0 && [ string match "*Formatting floppy*" $line ] } {
			break;
		    }
		    incr lines
		}
		close $f
		if { $opt(verbose) && 0 < $lines &&  ! [ winfo exists .error ] } {
		    .top.message configure \
			    -text [ format [ gettext "Done (%s entries)" ] $lines ]
		}
		if { $list == "list" } {
		    set list_verbose $opt(verbose)
		    set width 50
		    if { $list_verbose } { set width 80 }

		    toplevel .list
		    wm title .list "TkTapeTool - File List"
		    wm transient .list .
		    listbox .list.list -width $width -height 25 \
			    -selectmode extended -exportselection false \
			    -yscrollcommand ".list.scroll set" \
			    -font { fixed }
		    scrollbar .list.scroll -orient vertical -command ".list.list yview"
		    pack .list.list -side left -fill both -expand true
		    pack .list.scroll -side left -fill y
		    set_geometry .list

		    .list.list delete 0 end
		    set f [ open $tmpfile.list r ]
		    while { 0 <= [ gets $f line ] } {
			if [ regexp {^[^d]} $line ] {
			    .list.list insert end $line
			}
		    }
		    close $f
		}
	    }
	}
	kill_children normal

        .top.list configure -state $read_ops
        .top.readbutton configure -state $read_ops
        .top.writebutton configure -state $write_ops
        .top.mt configure -state normal

	if [ winfo exists .error ] { raise .error }
    }
}

# Open Property popup window.
#
proc popup_props_panel { { map "map" } } {
    global opt device device_entry tape_devices
    global read_ops write_ops

    if { $map != "nomap" } {
        if [ winfo exists .props ] { destroy .props }

        toplevel .props
        wm title .props "TkTapeTool - Property"
        wm transient .props .
        wm resizable .props false false
        frame .props.device -relief raised -bd 1
        frame .props.opts -relief raised -bd 1
        frame .props.bot -relief raised -bd 1
        frame .props.opts.read -relief ridge -bd 2
        frame .props.opts.write -relief ridge -bd 2
        frame .props.opts.both -relief ridge -bd 2
        frame .props.opts.format
        frame .props.opts.compress

        pack .props.device .props.opts .props.bot -side top -fill both

        label .props.device.label -text [ gettext "Device:" ]
        menubutton .props.device.button -relief raised -indicatoron 1 \
                -menu .props.device.button.menu
        pack .props.device.label .props.device.button -side left -padx 1m -pady 2m

        label .props.opts.read_label \
		-text [ gettext "When Reading:" ]
        checkbutton .props.keep_old_files -variable opt(keep_old_files) \
                -text [ gettext "Don't overwrite existing files when extracting" ] \
		-state $read_ops
        checkbutton .props.unlink_first -variable opt(unlink_first) \
                -text [ gettext "Remove old file prior to extracting over it" ] \
		-state $read_ops
        checkbutton .props.same_permission -variable opt(same_permission) \
                -text [ gettext "Extract all protection information" ] \
		-state $read_ops
        checkbutton .props.ignore_zeros -variable opt(ignore_zeros) \
                -text [ gettext "Ignore blocks of zeros in archive" ] \
		-state $read_ops

        label .props.opts.write_label \
		-text [ gettext "When Writing:" ]
	label .props.format_label -text [ gettext "Format:" ]
        radiobutton .props.gnutar_archive -variable opt(format) -value "" \
                -text [ gettext "GNU tar" ] \
		-state $write_ops
        radiobutton .props.posix_archive -variable opt(format) -value "posix" \
                -text [ gettext "POSIX" ] \
		-state $write_ops
        radiobutton .props.old_archive -variable opt(format) -value "old" \
                -text [ gettext "V7" ] \
		-state $write_ops
        checkbutton .props.dereference -variable opt(dereference) \
                -text [ gettext "Dereference symbolic-links" ] \
		-state $write_ops
        checkbutton .props.one_file_system -variable opt(one_file_system) \
                -text [ gettext "Don't backup files in the other file system" ] \
		-state $write_ops
        # checkbutton .props.absolute_paths -variable opt(absolute_paths) \
        #        -text [ gettext "Don't strip leading `/'s from file names" ] \
	#	-state $write_ops

        label .props.opts.both_label -text [ gettext "Another Options:" ]
	label .props.compress_label -text [ gettext "Compress:" ]
        radiobutton .props.no_compress -variable opt(compress) -value "" \
                -text [ gettext "none" ]
        radiobutton .props.compress -variable opt(compress) -value "compress" \
                -text [ gettext "compress" ]
        radiobutton .props.gzip -variable opt(compress) -value "gzip" \
                -text [ gettext "gzip" ]
        checkbutton .props.multi_volume -variable opt(multi_volume) \
                -text [ gettext "Multi-volume archive" ]
        checkbutton .props.verbose -variable opt(verbose) \
                -text [ gettext "Display file list when processing" ]

        button .props.close -command { catch { destroy .props .remote } } \
		-text [ gettext "Close" ]
        button .props.save_props -command { save_props } \
		-text [ gettext "Save Settings" ]
        button .props.default_props -command { set_default } \
		-text [ gettext "Set to Default Settings" ]

        pack .props.opts.read_label -side top -anchor w -padx 1m
        pack .props.opts.read -side top -anchor w -padx 8m -pady 2m -fill x
        pack .props.opts.write_label -side top -anchor w -padx 2m
        pack .props.opts.write -side top -anchor w -padx 8m -pady 2m -fill x
        pack .props.opts.both_label -side top -anchor w -padx 1m
        pack .props.opts.both -side top -anchor w -padx 8m -pady 2m -fill x

        pack .props.keep_old_files .props.unlink_first .props.ignore_zeros \
		.props.same_permission \
                -in .props.opts.read -side top -anchor w -padx 2m
        pack .props.format_label .props.gnutar_archive .props.posix_archive \
		.props.old_archive \
                -in .props.opts.format -side left -anchor w
        pack .props.opts.format \
		.props.dereference .props.one_file_system \
                -in .props.opts.write -side top -anchor w -padx 2m
        pack .props.compress_label .props.no_compress .props.compress .props.gzip \
                -in .props.opts.compress -side left -anchor w
        pack .props.opts.compress \
                -in .props.opts.both -side top -anchor w -padx 2m
        pack .props.multi_volume .props.verbose \
                -in .props.opts.both -side top -anchor w -padx 2m
        pack .props.close \
		-side left -in .props.bot -anchor w -padx 1m -pady 1m
        pack .props.default_props .props.save_props \
		-side right -in .props.bot -anchor w -padx 1m -pady 1m

        menu .props.device.button.menu -tearoff false

	set_geometry .props
    }

    if { $map != "nomap" } {
	set last_dev "/dev/null"
	foreach dev [ concat $tape_devices "Remote..." ] {
	    if [ regexp "^$last_dev\[^0-9\]" $dev junk ] {
		if { ! [ winfo exists .props.device.button.menu.$last_dev ] } {
		    menu .props.device.button.menu.$last_dev -tearoff false
		    .props.device.button.menu add cascade -label $last_dev* \
			    -menu .props.device.button.menu.$last_dev
		}
		.props.device.button.menu.$last_dev add command -label $dev \
			-command "props_device_select $dev"
	    } else {
		set dev [ gettext $dev ]
		.props.device.button.menu add command -label $dev \
			-command "props_device_select $dev"
		set last_dev $dev
	    }
        }
    }
    
    props_device_select $device_entry
}

# Callback for Device menu in the Property popup window.
#
proc props_device_select dev {
    global device device_entry tape_devices write_ops
    global remote_host remote_user remote_device

    if { $dev == "" } { set dev [ lindex $tape_devices 0 ] }

    set device $dev
    if { $dev == [ gettext "Other" ] } {
	set inx -1
    } elseif { $dev == [ gettext "Remote..." ] } {
	set inx -1

	regexp {^([^@]*@)?([^:]*:)?(.*)$} $device_entry \
		junk remote_user remote_host remote_device
	regsub {@$} $remote_user "" remote_user
	regsub {:$} $remote_host "" remote_host

        if [ winfo exists .remote ] { destroy .remote }

        toplevel .remote
        wm title .remote "TkTapeTool - Remote Tape"
        wm transient .remote .
        wm resizable .remote false false

	frame .remote.entries -relief raised -bd 1
	frame .remote.bot -relief raised -bd 1

        frame .remote.host 
	label .remote.host.label -text [ gettext "Host:" ]
	entry .remote.host.entry -textvariable remote_host
	pack .remote.host.label .remote.host.entry -side left -padx 1m

        frame .remote.user
	label .remote.user.label -text [ gettext "User:" ]
	entry .remote.user.entry -textvariable remote_user
	pack .remote.user.label .remote.user.entry -side left -padx 1m

        frame .remote.device
	label .remote.device.label -text [ gettext "Device:" ]
	entry .remote.device.entry -textvariable remote_device
	pack .remote.device.label .remote.device.entry -side left -padx 1m

        button .remote.bot.set -text [ gettext "Set" ] \
		-command { if [ set_remote_device ] { destroy .remote } }
        button .remote.bot.cancel -text [ gettext "Cancel" ] \
		-command { destroy .remote }
	
	pack .remote.bot.set .remote.bot.cancel \
		-side left -pady 1m -padx 1m
	pack .remote.entries .remote.bot -side top -fill both
	pack .remote.host .remote.user .remote.device \
		-in .remote.entries -side top -pady 1m -fill both

	set_geometry .remote .props
	set_remote_device nocheck
    } else {
	set inx [ lsearch $tape_devices $dev ]
	if { 0 <= $inx } { set device_entry $dev }
    }

    if [ winfo exists .props ] {
        if { 0 <= $inx } {
            .props.device.button configure -text $dev
            if { [ winfo exists .props.device.entry ] } {
                destroy .props.device.entry
            }
        } else {
            .props.device.button configure -text [ gettext "Other" ]
            if { ! [ winfo exists .props.device.entry ] } {
                entry .props.device.entry -textvariable device_entry
                pack .props.device.entry -padx 1m -pady 2m -fill x -expand true
            }
        }
    }
    if [ regexp "^/dev/fd" $device_entry ] {
	.top.mt configure -text [ gettext "Floppy" ]
	.top.mt.menu entryconfigure [ gettext "Offline" ] -state disabled
	.top.mt.menu entryconfigure [ gettext "Rewind" ] -state disabled
	.top.mt.menu entryconfigure [ gettext "Retension" ] -state disabled
	.top.mt.menu entryconfigure [ gettext "Format Floppy" ] -state $write_ops
    } else {
	set state normal
	if [ string match "*:*" $device_entry ] { set state disabled }
	.top.mt configure -text [ gettext "Tape" ]
	.top.mt.menu entryconfigure [ gettext "Offline" ] -state $state
	.top.mt.menu entryconfigure [ gettext "Rewind" ] -state $state
	.top.mt.menu entryconfigure [ gettext "Retension" ] -state $state
	.top.mt.menu entryconfigure [ gettext "Format Floppy" ] -state disabled
    }
}

# Set device name for remote tape device.
#
proc set_remote_device { { check "check" } } {
    global device_entry
    global remote_host remote_user remote_device

    if { $check != "nocheck" && \
	    ($remote_host == "" || $remote_device == "")  } {
	show_error "To use remote tape, you must specify host name\
		(or IP address) and device name." .remote
	return 0
    } else {
	set device_entry "$remote_user@$remote_host:$remote_device"
	regsub {^@} $device_entry "" device_entry
	regsub {^:} $device_entry "" device_entry
	regsub {@:} $device_entry "@localhost:" device_entry
	props_device_select [ gettext "Other" ]
	return 1
    }
}

# Popup a window and show given error message.
#
proc show_error { msg { parent . } { silent 0 } } {
    if { $msg == "no device" } {
	set msg "Device name is not specified.\
		\nPlease select device on the Property panel and try again."
    }

    .top.message configure -text [ gettext "Error!" ]

    if [ winfo exists .error ] {
	destroy .error
    } else {
	set silent 0
    }

    toplevel .error
    wm title .error "TkTapeTool - Error"
    wm transient .error .

    frame .error.top -relief raised -bd 1
    frame .error.bot -relief raised -bd 1

    pack .error.top -side top -fill both -expand true
    pack .error.bot -side bottom -fill both

    label .error.mark -bitmap warning
    label .error.message -text [ gettext $msg ] -justify left -wraplength 450
    pack .error.mark .error.message -in .error.top \
            -side left -padx 3m -pady 3m -fill both -expand true

    button .error.ok -text [ gettext "OK" ] -command { destroy .error }
    pack .error.ok -in .error.bot -side bottom -pady 1m

    set_geometry .error $parent
    if { ! $silent } { bell }
}

# Set window geometry
#
proc set_geometry { window { parent . } } {
    if { ! [ winfo exists $parent ] } { set parent . }

    set x [ expr [ winfo rootx $parent ] + [ winfo width $parent ] / 4 ]
    set y [ expr [ winfo rooty $parent ] + [ winfo height $parent ] / 4 ]
    wm geometry $window "+$x+$y"

    update
    set x1 [ expr [ winfo screenwidth $parent ] - [ winfo width $window ] - 10 ]
    set y1 [ expr [ winfo screenheight $parent ] - [ winfo height $window ] - 15 ]
    if { $x1 < 0 } { set x1 0 }
    if { $y1 < 0 } { set y1 0 }
    if { $x1 < $x || $y1 < $y } {
	if { $x1 < $x } { set x $x1 }
	if { $y1 < $y } { set y $y1 }
	wm geometry $window "+$x+$y"
    }
}

################################################################
# File browser

proc browse_directory { mode dir } {
    global browse_mode cur_folder

    set browse_mode $mode
    set cur_folder $dir

    if [ winfo exists .dir ] { destroy .dir }

    toplevel .dir
    wm title .dir "TkTapeTool - Browse"
    wm transient .dir .

    frame .dir.bottom_frame
    label .dir.folder_label -text [ gettext "Current Directory:" ]
    entry .dir.cur_folder -textvariable cur_folder -width 50
    bind .dir.cur_folder <Return> { refresh_directroy }

    listbox .dir.list -width 30 -height 10 \
	    -selectmode single -exportselection false \
	    -yscrollcommand ".dir.scroll set"
    scrollbar .dir.scroll -orient vertical -command ".dir.list yview"
    button .dir.done -text [ gettext "Set" ] -command { browse_done }
    button .dir.cancel -text [ gettext "Cancel" ] -command { destroy .dir }

    pack .dir.folder_label -side top -anchor w
    pack .dir.cur_folder -side top -anchor w -padx 6m -fill x
    pack .dir.bottom_frame -side bottom

    pack .dir.list -side left -pady 3m -fill both -expand true
    pack .dir.scroll -side right -pady 3m -fill y

    pack .dir.done .dir.cancel -in .dir.bottom_frame -side left -padx 1m
    set_geometry .dir

    bind .dir.list <ButtonRelease> { refresh_directroy }

    refresh_directroy
}

proc refresh_directroy {} {
    global browse_mode cur_folder org_dir

    if { $cur_folder == "" } { set cur_folder "/" }

    set n [ .dir.list curselection ]
    set s "/"
    if { 0 <= $n } {
	set s [ .dir.list get $n ]
	if { ! [ string match "*/" $cur_folder ] } { append cur_folder "/" }
	if [ string match "..*" $s ] {
	    regexp {^(.*/)[^/]+/?$} $cur_folder junk cur_folder
	} else {
	    set s "$cur_folder$s"
	    if [ file isdirectory $s ] { set cur_folder $s }
	}
    }

    if [ file isdirectory $s ] {
	.dir.list delete 0 end
	if { ! [ change_dir $cur_folder ] } {
	    set cur_folder $org_dir
	    change_dir $cur_folder
	}
	if { $cur_folder != "/" } { .dir.list insert end ".." }
	catch {
	    foreach f [ lsort [ glob * ] ] {
		if [ file isdirectory $f ] {
		    .dir.list insert end "$f/"
		}
	    }
	    if { $browse_mode != "basedir" } {
		foreach f [ lsort [ glob * ] ] {
		    if { ! [ file isdirectory $f ] } {
			.dir.list insert end $f
		    }
		}
	    }
	}
    }
}

proc browse_done {} {
    global browse_mode cur_folder base_dir

    if { $browse_mode == "basedir" } {
	set base_dir $cur_folder
    } else {
	set s $cur_folder
	set n [ .dir.list curselection ]
	if { 0 <= $n } {
	    if { ! [ string match "*/" $s ] } { append s "/" }
	    append s "[ .dir.list get $n ]"
	}
	.top.ftw_entry insert end "$s\n"
    }
    destroy .dir
}

################################################################
# The main routine.
#

set query ""
set files ""
if [ string match "-*" [ lindex $argv 0 ] ] {
    set s1 [ lindex $argv 0 ]
    switch -glob -- $s1 {
	"-q*" {
	    set query $s1
	}
	"-readonly" {
	    set write_ops "disabled"
	}
	"-writeonly" {
	    set read_ops "disabled"
	}
	default {
	    puts "tktapetool: unknown option: $s1"
	    exit 1
	}
    }
    set files [ lrange $argv 1 [ expr $argc - 1 ] ]
} else {
    set files $argv
}

if { $query != "" } {
    # ask user to insert new medium.

    regexp -- {^-q([^,]*)(,(.*))?$} $query junk mode junk device
    if { $device == "" } { set device "the drive" }

    wm protocol . WM_DELETE_WINDOW {
	if { [ tk_messageBox -title "Insert New Medium - Abort?" \
		-type yesno -icon question \
		-message [ format [ gettext "Do you want to abort processing on %s?" ] \
		$device ] ] == "yes" } {
	    set tar_pid [ ppid [ pid ] ]
	    if { 1 < $tar_pid } { exec kill -KILL $tar_pid }
	    exit 1
	}
    }

    wm title . "$program_name - Insert the Next Medium"
    frame .top -borderwidth 2
    frame .top.f1 -relief raised -bd 1
    frame .top.f2 -relief raised -bd 1
    pack .top -side top -padx 1 -pady 1 -fill both -expand true

    switch $mode {
	c { set msg \
		"Please insert a new medium in %s to write remaining files\
		and then click on \"Continue\"." }
	t { set msg \
		"Please insert medium of the next volume in %s to list remaining files\
		and then click on \"Continue\"." }
	x { set msg \
		"Please insert medium of the next volume in %s to extract remaining files\
		and then click on \"Continue\"." }
	default { set msg \
		"Please insert medium of the next volume in %s to process remaining files\
		and then click on \"Continue\"." }
    }

    label .top.f1.message -justify left -wraplength 400 \
	    -text [ format [ gettext $msg ] $device ]
    button .top.f2.ok_button -text [ gettext "Continue" ] -command { exit 0 }
    
    pack .top.f1 .top.f2 -fill both
    pack .top.f1.message .top.f2.ok_button -padx 5m -pady 1m

    bell

} else {
    # normal starup

    wm protocol . WM_DELETE_WINDOW {
	if { [ list_children {} ] != "" } {
	    bell
	    if { [ tk_messageBox -title "TkTapeTool - Confirm Quit" \
		    -type yesno -icon question \
		    -message [ gettext "Child process exists.\
		    \nDo you really want to quit TkTapeTool?" ] ] == "yes" } {
		kill_children
		exit 2
	    }
	} else {
	    kill_children
	    exit 0
	}
    }

    frame .top
    pack .top -side top -fill both -expand true
    frame .top.f1
    frame .top.f2
    pack .top.f1 -side top -pady 1m -fill x -padx 1m -pady 3m
    pack .top.f2 -side top -pady 1m -fill both -expand true

    button .top.list -text [ gettext "List..." ] -command { list_tape }
    menubutton .top.readbutton -text [ gettext "Read" ] \
	    -relief raised -indicatoron 1 -menu .top.readbutton.menu -state $read_ops
    menu .top.readbutton.menu -tearoff false
    .top.readbutton.menu add command -label [ gettext "Read Selected Files" ] \
	    -command { read_selected }
    .top.readbutton.menu add command -label [ gettext "Read Entier Tape" ] \
	    -command { read_entier_tape }

    button .top.writebutton -text [ gettext "Write" ] \
	    -command { write_tape } -state $write_ops

    menubutton .top.mt -text [ gettext "Tape" ] \
	    -relief raised -indicatoron true -menu .top.mt.menu
    menu .top.mt.menu -tearoff false
    .top.mt.menu add command -label [ gettext "Offline" ] -command { mt_ops offline }
    .top.mt.menu add command -label [ gettext "Rewind" ] -command { mt_ops rewind }
    .top.mt.menu add command -label [ gettext "Retension" ] -command { mt_ops retension }
    .top.mt.menu add separator
    .top.mt.menu add command -label [ gettext "Format Floppy" ] -command { fdd_format }

    button .top.props_button -text [ gettext "Property..." ] -command { popup_props_panel }

    pack .top.list         -in .top.f1 -side left -padx 1m
    pack .top.readbutton   -in .top.f1 -side left -padx 1m -ipady 1
    pack .top.writebutton  -in .top.f1 -side left -padx 1m
    pack .top.mt           -in .top.f1 -side left -padx 1m -ipady 1
    pack .top.props_button -in .top.f1 -side left -padx 5m

    set folder_image [image create bitmap -data {
	#define folder_width 32
	#define folder_height 16
	static unsigned char folder_bits[] = {
	    0x00, 0x00, 0x00, 0x00, 0xc0, 0x03, 0x00, 0x00, 0x20, 0x04, 0x00, 0x00,
	    0x18, 0xf8, 0x00, 0x00, 0x04, 0x00, 0x01, 0x00, 0x04, 0x00, 0x03, 0x00,
	    0x04, 0x00, 0x03, 0x00, 0x04, 0x00, 0x03, 0x00, 0x04, 0x00, 0x03, 0x00,
	    0x04, 0x00, 0x03, 0x00, 0x04, 0x00, 0x03, 0x00, 0x04, 0x00, 0x03, 0x00,
	    0x04, 0x00, 0x33, 0x33, 0xfc, 0xff, 0x33, 0x33, 0xf0, 0xff, 0x03, 0x00,
	    0x00, 0x00, 0x00, 0x00, };
	} ]

    frame .top.base_frame
    label .top.base_label -text [ gettext "Base Directory:" ]
    button .top.base_browse -image $folder_image -pady 1 \
	    -command { browse_directory basedir $base_dir }
    entry .top.base_entry -width 40 -textvariable base_dir -font { fixed }

    frame .top.blank1 -height 3m

    frame .top.ftw_frame
    label .top.ftw_label -text [ gettext "Files or Directories to Write:" ]
    button .top.ftw_browse -image $folder_image -pady 1 \
	    -command { browse_directory filetowrite $base_dir }
    text .top.ftw_entry -width 40 -height 7 -state $write_ops
    .top.ftw_entry insert end [ join $files "\n" ]

    label .top.message -text ""

    pack .top.base_frame -in .top.f2 -side top -anchor w
    pack .top.base_label .top.base_browse -in .top.base_frame -side left
    pack .top.base_entry -in .top.f2 -side top -anchor w -padx 5m -fill x
    pack .top.blank1 -in .top.f2 -side top
    if { $write_ops != "disabled" } {
	pack .top.ftw_frame -in .top.f2 -side top -anchor w
	pack .top.ftw_label .top.ftw_browse -in .top.ftw_frame -side left
	pack .top.ftw_entry -in .top.f2 -side top -anchor w -padx 5m -fill both -expand true
    }
    pack .top.message -in .top -side bottom -anchor w

    popup_props_panel nomap
}