5800 lines
177 KiB
Tcl
Executable File
5800 lines
177 KiB
Tcl
Executable File
#!/usr/bin/wish
|
|
#
|
|
# xorriso-tcltk
|
|
# Copyright (C) 2012 - 2013
|
|
# Thomas Schmitt <scdbackup@gmx.net>, libburnia project.
|
|
# Provided under BSD license: Use, modify, and distribute as you like.
|
|
#
|
|
# This is mainly a proof of concept for xorriso serving under a frontend.
|
|
# It exercises several fundamental gestures of communication:
|
|
# - connecting via two named pipes
|
|
# - sending commands
|
|
# - receiving replies
|
|
# - inquiring the xorriso message sieve
|
|
# - using the xorriso parsing service
|
|
|
|
# Note that any other language than Tcl/Tk could be used, if it only can
|
|
# do i/o via standard input and standard output or via named pipes.
|
|
# Further it has to perform integer arithmetics and string manipulations.
|
|
# And, well, a graphical widget set would be nice.
|
|
|
|
|
|
set own_version "1.2.5"
|
|
|
|
# Minimum version of xorriso to be used as backend provess.
|
|
# Older versions of xorriso do not offer commands -msg_op and -launch_frontend
|
|
set min_xorriso_version "1.2.5"
|
|
|
|
|
|
proc print_usage {argv0} {
|
|
puts stderr "Usage:"
|
|
puts stderr " $argv0 \[options\]"
|
|
puts stderr "Options:"
|
|
puts stderr " All options must be given with two dashes (\"--option\") in"
|
|
puts stderr " order to distinguish them from any options of the Tcl shell."
|
|
puts stderr " --help"
|
|
puts stderr " Print this text and exit."
|
|
puts stderr " --stdio"
|
|
puts stderr " Establish connection to xorriso via stdin and stdout."
|
|
puts stderr " E.g. when letting xorriso start this frontend program:"
|
|
puts stderr " xorriso -launch_frontend \$(which xorriso-tcltk) --stdio --"
|
|
puts stderr " --named_pipes cmd_fifo reply_fifo"
|
|
puts stderr " Establish connection to a xorriso process started by:"
|
|
puts stderr " xorriso -dialog on <cmd_fifo >reply_fifo"
|
|
puts stderr " which is then ready for a run of:"
|
|
puts stderr " xorriso-tcltk --named_pipes cmd_fifo reply_fifo"
|
|
puts stderr " It is important that the parent of xorriso and of this"
|
|
puts stderr " tcl/tk frontend opens the named pipe for commands before"
|
|
puts stderr " it opens the named pipe for replies. This avoids deadlock."
|
|
puts stderr " --silent_start"
|
|
puts stderr " Do not issue the start message xorriso-tcltk-version."
|
|
puts stderr " This works only if --silent_start is the first argument."
|
|
puts stderr " --no_bwidget"
|
|
puts stderr " Do not try to load the Tcl/Tk package BWidget which is"
|
|
puts stderr " a prerequisite for the \"/\" file browser buttons."
|
|
puts stderr " --geometry {+|-}X{+|-}Y"
|
|
puts stderr " Sets the position of the main window."
|
|
puts stderr " --click_to_focus"
|
|
puts stderr " Chooses that input fields and list boxes get the keyboard"
|
|
puts stderr " focus only when being clicked by the mouse. (Default)"
|
|
puts stderr " --auto_focus"
|
|
puts stderr " Chooses that the keyboard focus is where the mouse"
|
|
puts stderr " pointer is."
|
|
puts stderr " --pipe_log_file path"
|
|
puts stderr " Set a file address for logging of xorriso commands and"
|
|
puts stderr " reply messages and enable this logging."
|
|
puts stderr " The log lines will be appended. Path \"-\" means stderr."
|
|
puts stderr " --script_log_file path"
|
|
puts stderr " Set a file address for logging of major xorriso commands"
|
|
puts stderr " and enable this logging."
|
|
puts stderr " The log lines will be appended. Path \"-\" means stderr."
|
|
puts stderr ""
|
|
puts stderr "If neither --stdio nor --named_pipes is given, then this script"
|
|
puts stderr "will try to locate itself in the filesystem and start a xorriso"
|
|
puts stderr "run that launches it again."
|
|
puts stderr ""
|
|
puts stderr "In the running GUI, click with the rightmost mouse button on"
|
|
puts stderr "any GUI element to get its particular help text."
|
|
puts stderr ""
|
|
}
|
|
|
|
|
|
# ------------------------------- the frontend ----------------------------
|
|
#
|
|
# Starts xorriso, connects to it, sends commands, receives replies,
|
|
# prepares replies for GUI
|
|
|
|
# Connection to xorriso
|
|
set cmd_conn ""
|
|
set reply_conn ""
|
|
|
|
# The addresses of the named pipes, if such are used (see option -named_pipe)
|
|
set cmd_pipe_adr ""
|
|
set reply_pipe_adr ""
|
|
|
|
# The command to send (resp. the command most recently sent)
|
|
set cmdline ""
|
|
# Wether to clear the cmdline after sending
|
|
set cmdline_clear true
|
|
# Command counter
|
|
set cmd_sent 0
|
|
# Current -mark synchronization text
|
|
set mark_count 0
|
|
|
|
# Results of most recent await_all_replies
|
|
set info_list ""
|
|
set info_count 0
|
|
set emerging_info ""
|
|
set result_list ""
|
|
set result_count 0
|
|
set emerging_result ""
|
|
|
|
# Highest severities encountered in total and with most recent command
|
|
set highest_total_sev ALL
|
|
set highest_total_sev_msg ""
|
|
set highest_cmd_sev ALL
|
|
set highest_cmd_sev_msg ""
|
|
# This one registers like highest_cmd_sev with threshold ALL
|
|
set highest_seen_cmd_sev ALL
|
|
|
|
# State of last read_sieve command
|
|
set sieve_ret 0
|
|
|
|
# Mode for parsing replies with multiple words of arbitrary characters
|
|
# 0= single -msg_op parse commands
|
|
# 1= -msg_op parse_bulk (less problems with connection latency)
|
|
set bulk_parse_mode 1
|
|
# How many texts to pass with one parse_bulk command
|
|
set bulk_parse_max_chunk 200
|
|
# Parse parameters
|
|
set bulk_parse_prefix ""
|
|
set bulk_parse_separators ""
|
|
set bulk_parse_max_words ""
|
|
set bulk_parse_flag ""
|
|
# The announced number of texts to parse
|
|
set bulk_parse_num_texts ""
|
|
|
|
# Whether to complain on stderr about broken pipes.
|
|
# This may be expected when xorriso is being shut down by this frontend.
|
|
set expect_broken_pipes "0"
|
|
|
|
|
|
# Local copies of xorriso state
|
|
|
|
# Addresses of drives (or image files) as shown by their text fields in the GUI
|
|
set outdev_adr ""
|
|
set indev_adr ""
|
|
|
|
# Addresses of drives (or image files) as set in xorriso (after inquire_dev)
|
|
set eff_outdev_adr ""
|
|
set eff_indev_adr ""
|
|
|
|
# Whether the medium is blank, appendable, closed, missing
|
|
set indev_medium_status "missing"
|
|
set outdev_medium_status "missing"
|
|
|
|
# What kind of medium is presented by the drive
|
|
set indev_profile ""
|
|
set outdev_profile ""
|
|
|
|
# List of known drive addresses
|
|
set devlist ""
|
|
|
|
# Intermediate storage for messages until the GUI is up with .msglist box
|
|
set pre_msglist ""
|
|
|
|
# Whether overwriting of files in the ISO model is allowed
|
|
set overwrite_iso_files 1
|
|
|
|
# If overwrite_iso_files is 1: Wether overwriting of ISO directories is allowed
|
|
set overwrite_iso_dirs 0
|
|
|
|
# Whether overwriting of files on disk is allowed
|
|
set overwrite_disk_files 0
|
|
|
|
# The file where to log commands and replies for debugging purposes
|
|
set debug_log_file ""
|
|
set debug_log_conn stderr
|
|
|
|
# Whether to log all commands and replies to the debug_log_file
|
|
set debug_logging 0
|
|
|
|
# The result of the most recent isofs_ls run
|
|
set isofs_ls_result ""
|
|
|
|
# The communication channel where to log files (if it is not the empty text)
|
|
set cmd_log_conn ""
|
|
|
|
# The address under which cmd_log_conn was opened
|
|
set cmd_log_target ""
|
|
|
|
# Whether to log essential commands: 0=off , 1=no extract , 2=with extract
|
|
set cmd_logging_mode 0
|
|
|
|
# The last logged -cd path. Used to prevent redundant logging of -cd.
|
|
set recent_cd_path ""
|
|
|
|
# The file address and the channel for xorriso command script execution
|
|
set execute_script_adr ""
|
|
set execute_script_conn ""
|
|
|
|
# Whether extraction to disk shall be allowed in scripts
|
|
set script_with_osirrox 0
|
|
|
|
# Whether extraction to disk is currently allowed
|
|
set osirrox_allowed 1
|
|
|
|
|
|
# xorriso specific constants
|
|
|
|
# List of severities (gets later overridden by -msg_op list_sev -)
|
|
set xorriso_severity_list {
|
|
ALL DEBUG UPDATE NOTE HINT WARNING SORRY MISHAP FAILURE FATAL ABORT NEVER
|
|
}
|
|
set scan_event_threshold HINT
|
|
|
|
|
|
# --------- Communication between frontend and xorriso ----------
|
|
|
|
|
|
# Open the connection to a pair of named pipes. Program option -named_pipes
|
|
#
|
|
proc init_frontend_named_pipes {cmd_pipe reply_pipe} {
|
|
global cmd_conn
|
|
global reply_conn
|
|
|
|
set cmd_conn [open $cmd_pipe w]
|
|
set reply_conn [open $reply_pipe r]
|
|
|
|
# Note: disencouraged flags would be necessary for opening idle fifo
|
|
# set reply_conn [open $reply_pipe {RDONLY NONBLOCK}]
|
|
|
|
}
|
|
|
|
|
|
# Send a command line to the xorriso process. Do not wait for reply.
|
|
#
|
|
proc send_async_cmd {cmd} {
|
|
global cmd_sent cmd_conn debug_logging debug_log_conn
|
|
|
|
display_busy 1
|
|
|
|
debug_log_puts \
|
|
" =============================================================="
|
|
debug_log_puts " $cmd"
|
|
display_msg "======> $cmd"
|
|
incr cmd_sent
|
|
puts $cmd_conn $cmd
|
|
flush $cmd_conn
|
|
}
|
|
|
|
|
|
# Send a command line and a -mark command to xorriso. Wait until the
|
|
# mark message confirms that all command output has been received.
|
|
#
|
|
proc send_marked_cmd {cmd} {
|
|
global cmd_conn mark_count
|
|
|
|
send_async_cmd $cmd
|
|
incr mark_count
|
|
set mark_cmd "-mark $mark_count"
|
|
debug_log_puts " $mark_cmd"
|
|
puts $cmd_conn $mark_cmd
|
|
flush $cmd_conn
|
|
await_all_replies
|
|
}
|
|
|
|
|
|
# Send a command and make it a candidate for the log script
|
|
#
|
|
proc send_loggable_cmd {cmd} {
|
|
log_command $cmd
|
|
send_marked_cmd $cmd
|
|
}
|
|
|
|
|
|
# Send a command that shall not be displayed in the message log
|
|
#
|
|
proc send_silent_cmd {cmd} {
|
|
set disp_en_mem [set_display_msg 0]
|
|
send_marked_cmd $cmd
|
|
set_display_msg $disp_en_mem
|
|
}
|
|
|
|
|
|
# Wait for the currently pending mark message to arrive.
|
|
# Buffer all received result lines and info messages.
|
|
#
|
|
proc await_all_replies {} {
|
|
global reply_conn mark_count result_count result_list
|
|
global info_count info_list expect_broken_pipes
|
|
global .busy_text
|
|
|
|
clear_reply_lists
|
|
|
|
while {1} {
|
|
set ret [gets $reply_conn line]
|
|
if {$ret < 0} {
|
|
if {$expect_broken_pipes != 1} {
|
|
puts stderr "EOF at reply pipe"
|
|
}
|
|
break
|
|
}
|
|
debug_log_puts $line
|
|
if {[string range $line 0 0] == "M"} {
|
|
if {[string range $line 5 end] == $mark_count} {
|
|
break
|
|
} else {
|
|
# outdated mark message
|
|
continue
|
|
}
|
|
}
|
|
|
|
de_pkt_line $line
|
|
}
|
|
|
|
display_busy 0
|
|
}
|
|
|
|
|
|
# Decode -pkt_output format to complete lines and buffer them.
|
|
#
|
|
proc de_pkt_line {line} {
|
|
global info_list
|
|
global info_count
|
|
global emerging_info
|
|
global result_list
|
|
global result_count
|
|
global emerging_result
|
|
|
|
# Distinguish R and I
|
|
set ch [string range $line 0 0]
|
|
|
|
set payload [string range $line 5 end]
|
|
if {$ch == "R"} {
|
|
set emerging_result "$emerging_result$payload"
|
|
} else { if {$ch == "I"} {
|
|
set emerging_info "$emerging_info$payload"
|
|
} else {
|
|
return ""
|
|
}}
|
|
|
|
# if line end : add to list
|
|
if {[string range $line 2 2] == "1"} {
|
|
if {$ch == "R"} {
|
|
lappend result_list $emerging_result
|
|
incr result_count
|
|
display_msg $emerging_result
|
|
set emerging_result ""
|
|
} else {
|
|
lappend info_list $emerging_info
|
|
incr info_count
|
|
display_msg $emerging_info
|
|
scan_info_for_event $emerging_info
|
|
set emerging_info ""
|
|
}
|
|
}
|
|
}
|
|
|
|
|
|
# Search in the decoded info messages for the most severe event reports.
|
|
#
|
|
proc scan_info_for_event {line} {
|
|
global highest_total_sev highest_total_sev_msg
|
|
global highest_cmd_sev highest_cmd_sev_msg highest_seen_cmd_sev
|
|
global scan_event_threshold
|
|
global display_msg_enabled
|
|
|
|
# check for word : CAPS : text ...
|
|
set ret [regexp {[a-z][a-z]*[ ]*: [A-Z][A-Z]* :} $line]
|
|
|
|
if {$ret != 1} {return ""}
|
|
|
|
# retrieve severity
|
|
set pos [string first ":" $line]
|
|
set sev [string range $line [expr $pos+2] end]
|
|
set pos [string first ":" $sev]
|
|
set sev [string range $sev 0 [expr $pos-2]];
|
|
|
|
if {[compare_sev $sev $highest_seen_cmd_sev] > 0} {
|
|
set highest_seen_cmd_sev $sev
|
|
}
|
|
|
|
if {[compare_sev $sev $scan_event_threshold] < 0} {return ""}
|
|
|
|
if {$display_msg_enabled == 0} {
|
|
set display_msg_enabled 1
|
|
display_msg $line
|
|
set display_msg_enabled 0
|
|
}
|
|
if {[compare_sev $sev $highest_total_sev] >= 0} {
|
|
set highest_total_sev $sev
|
|
set highest_total_sev_msg [escape_newline $line]
|
|
}
|
|
if {[compare_sev $sev $highest_cmd_sev] >= 0} {
|
|
set highest_cmd_sev $sev
|
|
set highest_cmd_sev_msg [escape_newline $line]
|
|
}
|
|
}
|
|
|
|
|
|
# Unpack the output format of -msg_op read_sieve into a result_list
|
|
# of strings which each hold one parsed word.
|
|
#
|
|
proc de_sieve {} {
|
|
global result_list
|
|
global sieve_ret
|
|
|
|
set sieve_ret [lindex $result_list 0]
|
|
set sieve_result_count [lindex $result_list 1]
|
|
|
|
set payload ""
|
|
set sieve_result_count 0
|
|
for {set i 2} {$i < [llength $result_list]} {incr i} {
|
|
set line ""
|
|
set num_lines [lindex $result_list $i]
|
|
for {set j 0} {$j < $num_lines} {incr j} {
|
|
incr i
|
|
set line "$line[lindex $result_list $i]"
|
|
if {$j < $num_lines - 1} {
|
|
set line "$line\n"
|
|
} else {
|
|
lappend payload $line
|
|
incr sieve_result_count
|
|
}
|
|
}
|
|
}
|
|
set result_list $payload
|
|
set result_count $sieve_result_count
|
|
}
|
|
|
|
|
|
# Alternative to proc await_all_replies. It waits for a line at one of the
|
|
# three channels and displays all lines which it receives before that line.
|
|
# Used before this frontend had the opportunity to set up xorriso by commands
|
|
# like -pkt_output "on".
|
|
#
|
|
proc wait_for_msg {prefix channel} {
|
|
global reply_conn
|
|
|
|
if {$channel == "M"} {
|
|
set channel_prefix "M:0: "
|
|
} else {
|
|
set channel_prefix "$channel:1: "
|
|
}
|
|
|
|
set prefix_l [string length $prefix]
|
|
while {1} {
|
|
|
|
# >>> Have a timeout
|
|
|
|
set ret [gets $reply_conn line]
|
|
if {$ret < 0} {
|
|
break
|
|
}
|
|
debug_log_puts $line
|
|
if {[string length $line] < $prefix_l} {
|
|
display_msg $line
|
|
continue
|
|
}
|
|
if {[string range $line 0 [expr $prefix_l-1]] == $prefix} {
|
|
return [string range $line $prefix_l end]
|
|
}
|
|
if {[string length $line] >= [expr $prefix_l+5]} {
|
|
if {[string range $line 0 4] == $channel_prefix} {
|
|
if {[string range $line 5 [expr $prefix_l+4]] == $prefix} {
|
|
return [string range $line [expr $prefix_l+5] end]
|
|
}
|
|
}
|
|
}
|
|
display_msg $line
|
|
}
|
|
}
|
|
|
|
|
|
# Reset the buffer for result lines and info messages.
|
|
#
|
|
proc clear_reply_lists {} {
|
|
global info_list
|
|
global info_count
|
|
global emerging_info
|
|
global result_list
|
|
global result_count
|
|
global emerging_result
|
|
|
|
set info_list ""
|
|
set info_count 0
|
|
set emerging_info ""
|
|
set result_list ""
|
|
set result_count 0
|
|
set emerging_result ""
|
|
}
|
|
|
|
|
|
# Reset the register of the most severe event for command sequences.
|
|
# Typically this is done before executing the commands of a procedure
|
|
# that is triggered by the user interface.
|
|
#
|
|
proc reset_highest_cmd_sev {} {
|
|
global highest_cmd_sev highest_cmd_sev_msg highest_seen_cmd_sev
|
|
|
|
set highest_cmd_sev ALL
|
|
set highest_cmd_sev_msg ""
|
|
set highest_seen_cmd_sev ALL
|
|
}
|
|
|
|
|
|
# Clear the recordings of the xorriso message sieve.
|
|
#
|
|
proc clear_sieve {} {
|
|
send_silent_cmd "-msg_op clear_sieve -"
|
|
}
|
|
|
|
|
|
# Obtain a recorded item from the xorriso message sieve.
|
|
#
|
|
proc read_sieve {name} {
|
|
send_silent_cmd "-msg_op read_sieve '$name'"
|
|
de_sieve
|
|
}
|
|
|
|
|
|
# ------- Inquiring xorriso status -------
|
|
|
|
|
|
# Get more information about drive that was inquired by recent -toc_of.
|
|
#
|
|
proc obtain_drive_info {dev} {
|
|
global result_list
|
|
global sieve_ret
|
|
global indev_medium_status outdev_medium_status
|
|
global indev_profile outdev_profile
|
|
|
|
set line ""
|
|
|
|
if {$dev == "in"} {
|
|
set indev_medium_status "missing"
|
|
set indev_profile ""
|
|
} else {
|
|
set outdev_medium_status "missing"
|
|
set outdev_profile ""
|
|
}
|
|
read_sieve "Media status :"
|
|
if {$sieve_ret > 0} {
|
|
set reply [lindex $result_list 0]
|
|
foreach i {blank appendable closed} {
|
|
if {[string first $i $reply] != -1} {
|
|
set line "$i "
|
|
if {$dev == "in"} {
|
|
set indev_medium_status $i
|
|
} else {
|
|
set outdev_medium_status $i
|
|
}
|
|
break
|
|
}
|
|
}
|
|
}
|
|
read_sieve "Media current:"
|
|
if {$sieve_ret > 0} {
|
|
set profile [lindex $result_list 0]
|
|
if {$profile == "is not recognizable"} {
|
|
set profile "no recognizable medium"
|
|
set line "$line$profile"
|
|
return $line
|
|
} else {
|
|
set line "$line$profile, "
|
|
if {$dev == "in"} {
|
|
set indev_profile $profile
|
|
} else {
|
|
set outdev_profile $profile
|
|
}
|
|
}
|
|
}
|
|
read_sieve "Media summary:"
|
|
if {$sieve_ret > 0} {
|
|
set line "$line[lindex $result_list 0] sessions, "
|
|
if {$dev == "in"} {
|
|
set line "$line[lindex $result_list 2] used"
|
|
} else {
|
|
set line "$line[lindex $result_list 3] free"
|
|
}
|
|
}
|
|
return $line
|
|
}
|
|
|
|
|
|
# Inquire whether changes of the ISO image are pending.
|
|
#
|
|
proc changes_are_pending {} {
|
|
global result_count result_list
|
|
|
|
send_silent_cmd "-changes_pending show_status"
|
|
if {$result_count >= 1} {
|
|
if {[lindex $result_list 0] == "-changes_pending no"} {
|
|
return "0"
|
|
}
|
|
return "1"
|
|
}
|
|
return ""
|
|
}
|
|
|
|
|
|
# Inquire the file type of an address in the xorriso ISO image tree.
|
|
# This is a precondition for writing the session. Vice versa pending changes
|
|
# block a change of the input drive or the program end.
|
|
#
|
|
proc get_iso_filetype {adr} {
|
|
global result_list result_count scan_event_threshold
|
|
|
|
set scan_event_mem $scan_event_threshold
|
|
set scan_event_threshold "SORRY"
|
|
send_silent_cmd "-lsdl [make_text_shellsafe $adr] --"
|
|
set scan_event_threshold $scan_event_mem
|
|
if {$result_count <= 0} {
|
|
return ""
|
|
}
|
|
return [string range [lindex $result_list 0] 0 0]
|
|
}
|
|
|
|
|
|
# Inquire whether an ISO image model has been created inside xorriso.
|
|
# This is a precondition for inserting files into the ISO tree model.
|
|
#
|
|
proc assert_iso_image {with_msg} {
|
|
global highest_seen_cmd_sev scan_event_threshold
|
|
|
|
set highest_seen_cmd_sev ""
|
|
set set_mem $scan_event_threshold
|
|
set scan_event_threshold "FATAL"
|
|
send_silent_cmd "-lsd / --"
|
|
set scan_event_threshold $set_mem
|
|
if {[compare_sev $highest_seen_cmd_sev "FAILURE"] >= 0} {
|
|
if {$with_msg == 1} {
|
|
xorriso_tcltk_errmsg "xorriso-tcltk : SORRY : First you need to create or load an ISO image by selecting a drive or an image file"
|
|
}
|
|
return "0"
|
|
}
|
|
return "1"
|
|
}
|
|
|
|
|
|
# Obtain the list of possible event severity names, sorted in ascending order
|
|
#
|
|
proc inquire_severity_list {} {
|
|
global xorriso_severity_list
|
|
global result_list
|
|
|
|
set disp_en_mem [set_display_msg 0]
|
|
send_marked_cmd "-msg_op list_sev -"
|
|
set_display_msg $disp_en_mem
|
|
if {[lindex $result_list 0] != ""} {
|
|
set xorriso_severity_list [split [lindex $result_list 0] " "]
|
|
}
|
|
}
|
|
|
|
|
|
# Parse-by-xorriso handler function for proc inquire_dev
|
|
#
|
|
proc set_inquired_dev {} {
|
|
global result_list eff_indev_adr eff_outdev_adr
|
|
|
|
if {[llength $result_list] < 2} {return ""}
|
|
set what [lindex $result_list 0]
|
|
if {$what == "-dev" || $what == "-indev"} {
|
|
set eff_indev_adr [lindex $result_list 1]
|
|
}
|
|
if {$what == "-dev" || $what == "-outdev"} {
|
|
set eff_outdev_adr [lindex $result_list 1]
|
|
}
|
|
}
|
|
|
|
|
|
# Inquire -indev and -outdev from xorriso and install in eff_indev_adr
|
|
# and eff_outdev_adr.
|
|
# (This could be done by -toc_of like in proc refresh_indev. But here
|
|
# i demonstrate the use of command -status and parsing its result by
|
|
# help of xorriso.)
|
|
#
|
|
proc inquire_dev {} {
|
|
set disp_en_mem [set_display_msg 0]
|
|
send_marked_cmd "-status -dev"
|
|
handle_result_list set_inquired_dev "''" "''" 2 0
|
|
set_display_msg $disp_en_mem
|
|
update idletasks
|
|
return ""
|
|
}
|
|
|
|
|
|
# Inquire -indev and -outdev from xorriso and install in indev_adr
|
|
# and outdev_adr.
|
|
#
|
|
proc update_dev_var {} {
|
|
global result_list eff_indev_adr eff_outdev_adr indev_adr outdev_adr
|
|
|
|
inquire_dev
|
|
set indev_adr $eff_indev_adr
|
|
set outdev_adr $eff_outdev_adr
|
|
}
|
|
|
|
|
|
# Parse-by-xorriso handler function for proc isofs_ls
|
|
#
|
|
proc isofs_ls_handler {} {
|
|
global result_list isofs_ls_result
|
|
|
|
if {[lindex $result_list 0] == "total"} {return ""}
|
|
lappend isofs_ls_result \
|
|
"[string range [lindex $result_list 0] 0 0] [lindex $result_list 8]"
|
|
}
|
|
|
|
|
|
# Produce a list of all files in a directory of the ISO model
|
|
#
|
|
proc isofs_ls {dir} {
|
|
global isofs_ls_result
|
|
|
|
set isofs_ls_result ""
|
|
set disp_en_mem [set_display_msg 0]
|
|
send_marked_cmd "-lsl [make_text_shellsafe $dir]"
|
|
handle_result_list isofs_ls_handler "''" "''" 0 0
|
|
set_display_msg $disp_en_mem
|
|
return $isofs_ls_result
|
|
}
|
|
|
|
|
|
# Tells the file type of an absolute path in the ISO model.
|
|
# Indicator characters like with ls -l. Empty text means non existing file.
|
|
#
|
|
proc isofs_filetype {path} {
|
|
global result_list
|
|
|
|
set disp_en_mem [set_display_msg 0]
|
|
send_marked_cmd "-lsdl [make_text_shellsafe $path]"
|
|
set_display_msg $disp_en_mem
|
|
if {[llength $result_list] < 1} {return ""}
|
|
return [string range [lindex $result_list 0] 0 0]
|
|
}
|
|
|
|
|
|
# Verify that the connected process runs a xorriso program that is modern
|
|
# enough. This is done before sending xorriso the setup commands.
|
|
#
|
|
proc check_xorriso_version {} {
|
|
global sieve_ret result_list pre_msglist xorriso_version min_xorriso_version
|
|
global reply_conn
|
|
|
|
set version "0.0.0 (= unknown)"
|
|
|
|
set disp_en_mem [set_display_msg 0]
|
|
|
|
# In order to see the pre-frontend messages of xorriso
|
|
# set an individual -mark and use send_async_cmd
|
|
|
|
set mark_text "xorriso-tcltk-version-check-[clock seconds]"
|
|
send_async_cmd "-mark [make_text_shellsafe $mark_text]"
|
|
set_display_msg $disp_en_mem
|
|
wait_for_msg $mark_text "M"
|
|
|
|
set_display_msg 0
|
|
send_async_cmd "-version"
|
|
|
|
set xorriso_version [wait_for_msg "xorriso version : " "R"]
|
|
|
|
if {$xorriso_version < $min_xorriso_version} {
|
|
puts stderr "xorriso-tcltk: xorriso-$xorriso_version is too old."
|
|
puts stderr "xorriso-tcltk: Need at least version $min_xorriso_version"
|
|
window_ack \
|
|
"xorriso-$xorriso_version is too old. Need at least version $min_xorriso_version" \
|
|
"red" "embedded"
|
|
central_exit 2
|
|
}
|
|
set_display_msg $disp_en_mem
|
|
}
|
|
|
|
|
|
# Commands which bring the connected xorriso process into the state that
|
|
# is expected by this frontend.
|
|
#
|
|
proc setup_xorriso {} {
|
|
set cmd ""
|
|
|
|
# Invalidate possible -mark 1
|
|
set cmd "$cmd -mark 0"
|
|
|
|
# Make replies digestible for await_all_replies
|
|
set cmd "$cmd -pkt_output on"
|
|
|
|
# Report version early
|
|
set cmd "$cmd -version"
|
|
|
|
# This frontend relies heavily on the message sieve
|
|
set cmd "$cmd -msg_op start_sieve -"
|
|
|
|
# -reassure questions from xorriso would not be properly handled by
|
|
# this frontend
|
|
set cmd "$cmd -reassure off"
|
|
|
|
set cmd "$cmd -abort_on NEVER"
|
|
set cmd "$cmd -return_with ABORT 32"
|
|
set cmd "$cmd -report_about UPDATE"
|
|
set cmd "$cmd -iso_rr_pattern off"
|
|
set cmd "$cmd -disk_pattern off"
|
|
|
|
set cmd "$cmd -for_backup"
|
|
set cmd "$cmd -hardlinks off"
|
|
set cmd "$cmd -follow mount:limit=100"
|
|
|
|
send_marked_cmd $cmd
|
|
inquire_severity_list
|
|
}
|
|
|
|
|
|
# Commands which should also be at the start of a log script
|
|
#
|
|
proc xorriso_loggable_init_cmds {} {
|
|
set cmd "-for_backup"
|
|
|
|
# There is a performance problem in xorriso with -hardlinks on and
|
|
# image manipulations. So for now -hardlinks is set to off.
|
|
set cmd "$cmd -hardlinks off"
|
|
|
|
set cmd "$cmd -follow mount:limit=100"
|
|
return $cmd
|
|
}
|
|
|
|
|
|
proc effectuate_permission_policy {} {
|
|
global permission_policy
|
|
|
|
if {$permission_policy == "readable"} {
|
|
send_loggable_cmd \
|
|
"-find / -exec chmod a+r -- -find / -type d -exec chmod a+x --"
|
|
}
|
|
if {$permission_policy == "readonly"} {
|
|
send_loggable_cmd \
|
|
"-find / -exec chmod a=r -- -find / -type d -exec chmod a+x --"
|
|
}
|
|
if {$permission_policy == "mkisofs_r"} {
|
|
send_loggable_cmd \
|
|
"-find / -exec mkisofs_r"
|
|
}
|
|
}
|
|
|
|
|
|
# ------ Parsing by help of xorriso ------
|
|
|
|
# Parsing by xorriso takes from the frontend the burden to understand
|
|
# and implement the quoting rules of xorriso input and output.
|
|
# Lines which are supposed to consist of several words get sent to
|
|
# xorriso command -msg_op. The result lines of this command encode
|
|
# the words unambigously in one or more text lines.
|
|
# This is supposed to be safe for even the weirdest file names.
|
|
# Only NUL characters cannot be part of names.
|
|
|
|
|
|
# If enabled: Start a bulk parser job by which xorriso shall split the output
|
|
# of e.g. -lsl into single words from which this frontend can pick information.
|
|
#
|
|
proc start_bulkparse {prefix separators max_words flag num_lines} {
|
|
global bulk_parse_mode bulk_parse_prefix bulk_parse_separators
|
|
global bulk_parse_max_words bulk_parse_flag bulk_parse_num_texts
|
|
|
|
if {$num_lines <= 0} {return ""}
|
|
|
|
set bulk_parse_prefix $prefix
|
|
set bulk_parse_separators $separators
|
|
set bulk_parse_max_words $max_words
|
|
set bulk_parse_flag $flag
|
|
set bulk_parse_num_texts $num_lines
|
|
if {$bulk_parse_mode == 1} {
|
|
set cmd "-msg_op parse_bulk \"$prefix $separators $max_words $flag $num_lines\""
|
|
send_async_cmd $cmd
|
|
# Do not wait for mark
|
|
}
|
|
}
|
|
|
|
|
|
# Submit a new input line to the xorriso parser. If no bulk parser job was
|
|
# started then submit a single line parser command.
|
|
#
|
|
proc submit_bulkparse {text} {
|
|
global cmd_conn reply_conn
|
|
global result_list result_count
|
|
global bulk_parse_mode bulk_parse_prefix bulk_parse_separators
|
|
global bulk_parse_max_words bulk_parse_flag
|
|
|
|
if {$bulk_parse_mode != 1} {
|
|
clear_reply_lists
|
|
}
|
|
set disp_en_mem [set_display_msg 0]
|
|
|
|
set num_lines [expr [count_newlines $text] + 1]
|
|
|
|
if {$bulk_parse_mode == 0} {
|
|
set cmd "-msg_op parse \"$bulk_parse_prefix $bulk_parse_separators $bulk_parse_max_words $bulk_parse_flag $num_lines\""
|
|
send_async_cmd $cmd
|
|
} else {
|
|
debug_log_puts ">>>>> $num_lines"
|
|
puts $cmd_conn $num_lines
|
|
}
|
|
debug_log_puts ">>>>> $text"
|
|
puts $cmd_conn $text
|
|
flush $cmd_conn
|
|
|
|
if {$bulk_parse_mode != 1} {
|
|
set loop_limit 2
|
|
while {$result_count < $loop_limit} {
|
|
set ret [gets $reply_conn line]
|
|
if {$ret < 0} { return ""}
|
|
debug_log_puts $line
|
|
de_pkt_line $line
|
|
if {$result_count == 1} {
|
|
set parse_ret [lindex $result_list 0]
|
|
}
|
|
if {$result_count == 2} {
|
|
set num_replies [lindex $result_list 1]
|
|
set loop_limit [expr "$num_replies * 2 + 2"]
|
|
}
|
|
}
|
|
de_sieve
|
|
}
|
|
set_display_msg $disp_en_mem
|
|
}
|
|
|
|
|
|
# If a bulk parsing job was started, then read the expected number of
|
|
# replies into the result buffer and call handler_proc to inspect them.
|
|
# Each input line of the parser yields one reply buffer full of parsed words.
|
|
#
|
|
proc read_bulkparse {handler_proc num_texts} {
|
|
global bulk_parse_mode
|
|
|
|
if {$bulk_parse_mode != 1} { return ""}
|
|
|
|
set disp_en_mem [set_display_msg 0]
|
|
for {set i 0} {$i < $num_texts} {incr i} {
|
|
clear_reply_lists
|
|
read_parse_reply
|
|
$handler_proc
|
|
}
|
|
set_display_msg $disp_en_mem
|
|
}
|
|
|
|
|
|
# Read and decode the xorriso parser reply for one input line.
|
|
#
|
|
proc read_parse_reply {} {
|
|
global reply_conn
|
|
global result_list result_count
|
|
|
|
set loop_limit 2
|
|
while {$result_count < $loop_limit} {
|
|
set ret [gets $reply_conn line]
|
|
if {$ret < 0} { return ""}
|
|
debug_log_puts $line
|
|
de_pkt_line $line
|
|
if {$result_count == 1} {
|
|
set parse_ret [lindex $result_list 0]
|
|
}
|
|
if {$result_count == 2} {
|
|
set num_replies [lindex $result_list 1]
|
|
set loop_limit [expr "$num_replies * 2 + 2"]
|
|
}
|
|
}
|
|
de_sieve
|
|
}
|
|
|
|
|
|
# Let xorriso parse the lines in the result buffer and call handler_proc
|
|
# with the parse result of each line.
|
|
# This is used to split the result lines of -lsl into words from which
|
|
# handler proc isolist_parse_handler picks the info which it displays
|
|
# in .stbox isolist .
|
|
# Note that all parameters must be xorriso words. E.g. empty prefix or
|
|
# separator have to be submitted as tcl string "''" rather than "".
|
|
#
|
|
proc handle_result_list {handler_proc \
|
|
prefix separators max_words flag } {
|
|
global result_list
|
|
global bulk_parse_mode bulk_parse_max_chunk
|
|
|
|
set raw_list $result_list
|
|
set raw_line_count [expr [llength $raw_list]]
|
|
if {$raw_line_count > $bulk_parse_max_chunk} {
|
|
set chunk_size $bulk_parse_max_chunk
|
|
} else {
|
|
set chunk_size $raw_line_count
|
|
}
|
|
start_bulkparse $prefix $separators $max_words $flag $chunk_size
|
|
set submit_count 0
|
|
set submit_in_chunk_count 0
|
|
foreach i $raw_list {
|
|
submit_bulkparse $i
|
|
incr submit_count
|
|
incr submit_in_chunk_count
|
|
if {$bulk_parse_mode != 1} {
|
|
$handler_proc
|
|
}
|
|
if {$bulk_parse_mode == 1 && $submit_in_chunk_count == $chunk_size} {
|
|
read_bulkparse $handler_proc $chunk_size
|
|
set todo [expr "$raw_line_count - $submit_count"]
|
|
if {$todo <= 0} {
|
|
break
|
|
}
|
|
if {$todo > $bulk_parse_max_chunk} {
|
|
set chunk_size $bulk_parse_max_chunk
|
|
} else {
|
|
set chunk_size $todo
|
|
}
|
|
start_bulkparse $prefix $separators $max_words $flag \
|
|
$chunk_size
|
|
set submit_in_chunk_count 0
|
|
}
|
|
}
|
|
display_busy 0
|
|
}
|
|
|
|
|
|
# ------------------------------- the GUI ----------------------------
|
|
|
|
# ------ State variables ------
|
|
|
|
# Whether to display messages in .msglist
|
|
set display_msg_enabled 1
|
|
|
|
# Whether a device list is already displayed
|
|
set devices_scanned 0
|
|
|
|
# Currently displayed ISO directory
|
|
set isodir_adr ""
|
|
set isodir_is_pwd 0
|
|
|
|
# The plain names and types matching listbox .isolist
|
|
set isolist_names ""
|
|
set isolist_types ""
|
|
|
|
# The name which to select after isodir_return
|
|
set isodir_return_name ""
|
|
|
|
# The address where to move selected ISO files
|
|
set isomanip_move_target ""
|
|
|
|
# Memorized isolist selection
|
|
set memorized_isolist_selection ""
|
|
|
|
# Image file address for .burn_write_image
|
|
set burn_write_image_adr ""
|
|
|
|
# Whether to close medium after writing
|
|
set burn_write_close 0
|
|
|
|
# Whether to force CD TAO, DVD-R Inremental, DVD+R/BD-R open ended track
|
|
set burn_write_tao 0
|
|
|
|
# Whether to engage Defect Management on formatted BD media
|
|
set burn_write_defect_mgt 0
|
|
|
|
# Answer of yes/no window
|
|
set answer_of_yesno ""
|
|
|
|
# Semi-persistent answers of yes/no window
|
|
set yesno_to_all 0
|
|
|
|
# The hard disk filesystem address to be mapped into isodir_adr
|
|
set insert_from_adr ""
|
|
|
|
# Whether to insert with leafname of insert_from_adr underneath isodir_adr
|
|
# (else: -map $insert_from_adr $isodir_adr)
|
|
set insert_underneath 1
|
|
|
|
# Whether to insert at or under the selected .isolist item
|
|
# rather than isodir_adr
|
|
set insert_at_selected 0
|
|
|
|
# The hard disk filesystem address to which to extract from isodir_adr
|
|
set extract_to_adr ""
|
|
|
|
# Whether to insert with leafname of insert_from_adr underneath isodir_adr
|
|
# (else: -map $insert_from_adr $isodir_adr)
|
|
set extract_underneath 1
|
|
|
|
# Whether to insert at or under the selected .isolist item
|
|
set extract_from_selected 1
|
|
|
|
# Whether to temporarily enforce rwx permissions for target directories on disk
|
|
set extract_auto_chmod 0
|
|
|
|
# Whether the display label .busy_text is already usable
|
|
set busy_text_exists 0
|
|
|
|
# Whether to demand a click before focus goes to entry or listbox
|
|
set click_to_focus 1
|
|
|
|
# Whether .ack_window , .yesno_window , .help_window, .main_help_window
|
|
# are already displayed.
|
|
set ack_window_is_active 0
|
|
set yesno_window_is_active 0
|
|
set help_window_is_active 0
|
|
set main_help_window_is_active 0
|
|
|
|
# Positions of above windows when they were last closed
|
|
set yesno_window_geometry ""
|
|
set ack_window_geometry ""
|
|
set help_window_geometry ""
|
|
set main_help_window_geometry ""
|
|
|
|
# Whether the help window already has a scroll bar
|
|
set help_window_has_scroll 0
|
|
|
|
# Whether there is the BWidget package available: 0=unknown, 1=yes, -1=banned
|
|
#
|
|
set have_bwidget 0
|
|
set bwidget_version ""
|
|
|
|
# Whether the .browse_disk_window is already displayed
|
|
set browse_disk_window_is_active 0
|
|
set browse_disk_window_var ""
|
|
# Position of window when it was last closed
|
|
set browse_disk_window_geometry ""
|
|
# Whether the window is grabbed
|
|
set browse_disk_window_is_grabbed 0
|
|
|
|
# Whether the .browse_iso_window is already displayed
|
|
set browse_iso_window_is_active 0
|
|
set browse_iso_window_var ""
|
|
# Position of window when it was last closed
|
|
set browse_iso_window_geometry ""
|
|
# Whether the window is grabbed
|
|
set browse_iso_window_is_grabbed 0
|
|
|
|
# Whether to bring the selected browser item directly into the text field
|
|
set browse_select_is_setvar 0
|
|
|
|
# Whether to modify the ISO file permissions before writing the ISO session
|
|
# Policies: as_is , readable , readonly , mkisofs_r
|
|
set permission_policy "as_is"
|
|
|
|
|
|
# ------ GUI callback procedures ----
|
|
|
|
|
|
# Called when the Return key is hit in commandline.
|
|
#
|
|
proc cmdline_return {} {
|
|
global cmdline cmdline_clear
|
|
global .cmdline .cmdline_text .cmdline_entry
|
|
global highest_cmd_sev
|
|
global highest_cmd_sev_msg
|
|
|
|
reset_highest_cmd_sev
|
|
set_display_msg 1
|
|
send_loggable_cmd $cmdline
|
|
set cmdline ""
|
|
|
|
# To force display of GUI changes now and not some time later
|
|
update idletasks
|
|
}
|
|
|
|
|
|
# Called when the input drive address shall be brought into effect with
|
|
# xorriso.
|
|
#
|
|
proc indev_return {} {
|
|
global indev_adr
|
|
global .indev_entry
|
|
global .outdev_entry
|
|
|
|
if {[assert_no_changes] == 0} {
|
|
update_dev_var
|
|
return "0"
|
|
}
|
|
reset_highest_cmd_sev
|
|
send_loggable_cmd "-indev [make_text_shellsafe $indev_adr]"
|
|
set indev_mem_adr $indev_adr
|
|
.indev_entry icursor 0
|
|
refresh_indev
|
|
return "1"
|
|
}
|
|
|
|
|
|
# Called when the "Eject" button for the input drive is hit.
|
|
#
|
|
proc eject_indev {} {
|
|
if {[assert_no_changes] == 0} {return ""}
|
|
reset_highest_cmd_sev
|
|
send_loggable_cmd "-eject indev"
|
|
refresh_outdev
|
|
refresh_indev
|
|
}
|
|
|
|
|
|
# Called when the output drive address shall be brought into effect with
|
|
# xorriso.
|
|
#
|
|
proc outdev_return {} {
|
|
global outdev_adr indev_adr
|
|
global .outdev_entry
|
|
|
|
reset_highest_cmd_sev
|
|
send_loggable_cmd "-outdev [make_text_shellsafe $outdev_adr]"
|
|
set outdev_mem_adr $outdev_adr
|
|
.outdev_entry icursor 0
|
|
refresh_outdev
|
|
return "1"
|
|
}
|
|
|
|
|
|
# Called when the "Eject" button for the output drive is hit.
|
|
#
|
|
proc eject_outdev {} {
|
|
global outdev_adr indev_adr
|
|
|
|
if {$outdev_adr == $indev_adr} {
|
|
if {[assert_no_changes] == 0} {return ""}
|
|
}
|
|
reset_highest_cmd_sev
|
|
send_loggable_cmd "-eject outdev"
|
|
refresh_outdev
|
|
refresh_indev
|
|
}
|
|
|
|
|
|
# Called when both drive addresses shall be brought into effect with xorriso.
|
|
#
|
|
proc dev_return {} {
|
|
global outdev_adr indev_adr
|
|
global .outdev_entry .indev_entry
|
|
|
|
if {$outdev_adr != $indev_adr} {
|
|
if {[indev_return] == 0} {return "0"}
|
|
outdev_return
|
|
} else {
|
|
if {[assert_no_changes] == 0} {
|
|
update_dev_var
|
|
return "0"
|
|
}
|
|
reset_highest_cmd_sev
|
|
send_loggable_cmd "-dev [make_text_shellsafe $outdev_adr]"
|
|
.outdev_entry icursor 0
|
|
refresh_outdev
|
|
.indev_entry icursor 0
|
|
refresh_indev
|
|
}
|
|
}
|
|
|
|
|
|
# Obtain and display the input drive status.
|
|
# Called after the input drive address may have changed.
|
|
#
|
|
proc refresh_indev {} {
|
|
global result_list
|
|
global indev_adr
|
|
global sieve_ret
|
|
global .indev_summary
|
|
|
|
.indev_summary configure -text ""
|
|
set indev_adr ""
|
|
update idletasks
|
|
|
|
set disp_en_mem [set_display_msg 0]
|
|
clear_sieve
|
|
send_marked_cmd "-toc_of in:short"
|
|
read_sieve "Drive current:"
|
|
set_display_msg $disp_en_mem
|
|
if {$sieve_ret > 0} {
|
|
set cmd [lindex $result_list 0]
|
|
if {$cmd == "-indev" || $cmd == "-dev"} {
|
|
set indev_adr [lindex $result_list 1]
|
|
}
|
|
set line [obtain_drive_info in]
|
|
.indev_summary configure -text $line
|
|
}
|
|
.avail_label configure -text ""
|
|
update idletasks
|
|
isodir_return "refresh_indev"
|
|
}
|
|
|
|
|
|
# Obtain and display the output drive status.
|
|
# Called after the output drive address may have changed.
|
|
#
|
|
proc refresh_outdev {} {
|
|
global result_list
|
|
global outdev_adr
|
|
global sieve_ret
|
|
|
|
.outdev_summary configure -text ""
|
|
set outdev_adr ""
|
|
update idletasks
|
|
|
|
set disp_en_mem [set_display_msg 0]
|
|
clear_sieve
|
|
send_marked_cmd "-toc_of out:short"
|
|
read_sieve "Drive current:"
|
|
set_display_msg $disp_en_mem
|
|
if {$sieve_ret > 0} {
|
|
set cmd [lindex $result_list 0]
|
|
if {$cmd == "-outdev" || $cmd == "-dev"} {
|
|
set outdev_adr [lindex $result_list 1]
|
|
}
|
|
set line [obtain_drive_info out]
|
|
.outdev_summary configure -text $line
|
|
}
|
|
.avail_label configure -text ""
|
|
update idletasks
|
|
}
|
|
|
|
|
|
# Scan the system for optical drives with rw permission
|
|
# Called when the "Scan for drives button" is hit.
|
|
#
|
|
proc scan_for_drives {} {
|
|
global .drivelist .drive_drop_both .drive_scan
|
|
global sieve_ret result_list devlist devices_scanned indev_adr outdev_adr
|
|
|
|
if {[assert_no_changes] == 0} {return ""}
|
|
if {$indev_adr != "" || $outdev_adr != ""} {
|
|
if {[window_yesno \
|
|
"Really give up aquired drives for scanning a new drive list ?"] \
|
|
!= 1} { return "" }
|
|
}
|
|
|
|
set max_idx [.drivelist index end]
|
|
.drivelist delete 0 [expr $max_idx-1]
|
|
set devlist ""
|
|
|
|
reset_highest_cmd_sev
|
|
clear_sieve
|
|
send_loggable_cmd "-devices"
|
|
set max_idx 0
|
|
while {1} {
|
|
read_sieve "? -dev"
|
|
if {$sieve_ret > 0} {
|
|
.drivelist insert end "[lindex $result_list 0] : [lindex $result_list 2] [lindex $result_list 3]"
|
|
lappend devlist [lindex $result_list 0]
|
|
} else {
|
|
break
|
|
}
|
|
}
|
|
while {1} {
|
|
read_sieve "?? -dev"
|
|
if {$sieve_ret > 0} {
|
|
.drivelist insert end "[lindex $result_list 0] : [lindex $result_list 2] [lindex $result_list 3]"
|
|
lappend devlist [lindex $result_list 0]
|
|
} else {
|
|
break
|
|
}
|
|
}
|
|
set devices_scanned 1
|
|
reset_to_normal_background .drive_scan
|
|
|
|
# Command -devices drops all aquired drives
|
|
refresh_outdev
|
|
refresh_indev
|
|
}
|
|
|
|
|
|
# Refresh the display after some xorriso may have changed the status
|
|
# Called by the "Refresh disp" button and others.
|
|
#
|
|
proc refresh_state {} {
|
|
refresh_indev
|
|
refresh_outdev
|
|
}
|
|
|
|
|
|
# Reset the recorded Worst problem message.
|
|
# Called when the "Clear" button is hit.
|
|
#
|
|
proc clear_total_errmsg {} {
|
|
global highest_total_sev
|
|
global highest_total_sev_msg
|
|
|
|
set highest_total_sev ALL
|
|
set highest_total_sev_msg ""
|
|
update idletasks
|
|
}
|
|
|
|
|
|
# Called when the "Pick input drive button" is hit.
|
|
#
|
|
proc pick_indev {} {
|
|
pick_drive indev
|
|
}
|
|
|
|
|
|
# Called when the "Pick output drive button" is hit.
|
|
#
|
|
proc pick_outdev {} {
|
|
pick_drive outdev
|
|
}
|
|
|
|
|
|
# Called when the "Pick drive for both roles" button is hit.
|
|
# or when an item in the scanned drive list is double-clicked.
|
|
#
|
|
proc pick_dev {} {
|
|
pick_drive dev
|
|
}
|
|
|
|
|
|
# Perform the actual work of pick_dev, pick_indev, and pick_outdev
|
|
#
|
|
proc pick_drive {role} {
|
|
global .drivelist
|
|
global devlist
|
|
global highest_cmd_sev_msg outdev_adr indev_adr devices_scanned
|
|
|
|
set selected [.drivelist curselection]
|
|
if {[llength $selected] != 1} {
|
|
set must_scan ""
|
|
if {$devices_scanned == 0} { set must_scan " scan and"}
|
|
xorriso_tcltk_errmsg \
|
|
"xorriso-tcltk : SORRY : First you must$must_scan select a single drive"
|
|
return ""
|
|
}
|
|
set drive_idx [lindex $selected 0]
|
|
|
|
if {$role == "dev"} {
|
|
set outdev_adr [lindex $devlist $drive_idx]
|
|
set indev_adr [lindex $devlist $drive_idx]
|
|
dev_return
|
|
}
|
|
if {$role == "outdev"} {
|
|
set outdev_adr [lindex $devlist $drive_idx]
|
|
outdev_return
|
|
}
|
|
if {$role == "indev"} {
|
|
set indev_adr [lindex $devlist $drive_idx]
|
|
indev_return
|
|
}
|
|
.drivelist selection clear 0 end
|
|
}
|
|
|
|
|
|
# Called when the "Give up drives" button is hit.
|
|
#
|
|
proc give_up_dev {} {
|
|
global outdev_adr indev_adr
|
|
|
|
if {[assert_no_changes] == 0} {return ""}
|
|
set outdev_adr ""
|
|
outdev_return
|
|
set indev_adr ""
|
|
indev_return
|
|
}
|
|
|
|
|
|
# Obtain and display the content of the current ISO directory.
|
|
# Called when the Return key is hit in the .isodir_entry text field
|
|
# and by many others which change variable isodir_adr or the
|
|
# content of the directory in xorriso's tree model.
|
|
#
|
|
proc isodir_return {caller} {
|
|
global isodir_adr result_list isolist_names isolist_types isodir_return_name
|
|
global isodir_is_pwd highest_cmd_sev highest_cmd_sev_msg
|
|
global indev_adr outdev_adr eff_indev_adr
|
|
global .isolist
|
|
global bulk_parse_mode
|
|
global bulk_parse_max_chunk
|
|
|
|
set chunk_size 0
|
|
|
|
set max_idx [.isolist index end]
|
|
.isolist delete 0 [expr "$max_idx-1"]
|
|
update idletasks
|
|
set isolist_names ""
|
|
set isolist_types ""
|
|
|
|
inquire_dev
|
|
if {$eff_indev_adr == "" && [changes_are_pending] == "0"} {return ""}
|
|
|
|
normalize_isodir_adr
|
|
set file_type [isofs_filetype $isodir_adr]
|
|
if {$file_type != "d" && $file_type != ""} {
|
|
.isolist insert end "@@@ exists but is not a directory @@@"
|
|
set isodir_is_pwd 0
|
|
return ""
|
|
}
|
|
set disp_en_mem [set_display_msg 0]
|
|
set highest_cmd_sev_mem $highest_cmd_sev
|
|
set highest_cmd_sev_msg_mem $highest_cmd_sev_msg
|
|
reset_highest_cmd_sev
|
|
send_loggable_cmd "-cd [make_text_shellsafe $isodir_adr]"
|
|
if {[compare_sev $highest_cmd_sev "WARNING"] < 0} {
|
|
send_marked_cmd "-lsl --"
|
|
set isodir_is_pwd 1
|
|
} else {
|
|
send_marked_cmd "-lsl [make_text_shellsafe $isodir_adr] --"
|
|
set isodir_is_pwd 0
|
|
}
|
|
handle_result_list isolist_parse_handler "''" "''" 0 0
|
|
set_display_msg $disp_en_mem
|
|
set highest_cmd_sev $highest_cmd_sev_mem
|
|
set highest_cmd_sev_msg $highest_cmd_sev_msg_mem
|
|
|
|
if {$isodir_return_name != ""} {
|
|
set idx [lsearch -exact $isolist_names $isodir_return_name]
|
|
if {$idx != -1} {
|
|
.isolist see $idx
|
|
.isolist selection set $idx
|
|
}
|
|
set isodir_return_name ""
|
|
}
|
|
update idletasks
|
|
}
|
|
|
|
|
|
# The handler procedure that is submitted to proc handle_result_list
|
|
# and will be called for every parsed line.
|
|
# It records file names and types in separate lists and displays them
|
|
# in the .isolist box.
|
|
#
|
|
proc isolist_parse_handler {} {
|
|
global result_list isolist_names isolist_types
|
|
global .isolist
|
|
|
|
if {[lindex $result_list 0] == "total"} {return ""}
|
|
set name [lindex $result_list 8]
|
|
set ftype [string range [lindex $result_list 0] 0 0]
|
|
lappend isolist_names $name
|
|
lappend isolist_types $ftype
|
|
.isolist insert end "$ftype $name"
|
|
}
|
|
|
|
|
|
# Make current the ISO directory that was selected from the .isolist box.
|
|
# Called when an item in the .isolist box is double-clicked.
|
|
#
|
|
proc pick_isodir {} {
|
|
global isolist_names isolist_types isodir_adr isodir_return_name
|
|
global .isolist
|
|
|
|
set selected [.isolist curselection]
|
|
if {[llength $selected] != 1} {
|
|
xorriso_tcltk_errmsg \
|
|
"xorriso-tcltk : SORRY : First you must select a single directory"
|
|
return ""
|
|
}
|
|
set idx [lindex $selected 0]
|
|
if {[lindex $isolist_types $idx] != "d"} {
|
|
xorriso_tcltk_errmsg \
|
|
"xorriso-tcltk : SORRY : You may only double-click a directory"
|
|
return ""
|
|
}
|
|
if {$isodir_adr == "/"} {
|
|
set isodir_adr ""
|
|
}
|
|
set isodir_adr "$isodir_adr/[lindex $isolist_names $idx]"
|
|
set isodir_return_name ""
|
|
isodir_return "pick_isodir"
|
|
}
|
|
|
|
|
|
# Make current the parent directory of the current ISO directory.
|
|
# Called when the "Up" button is hit.
|
|
#
|
|
proc isodir_up {} {
|
|
global isodir_adr isodir_return_name
|
|
|
|
set isodir_return_name ""
|
|
set idx [string last "/" $isodir_adr]
|
|
set l [string length $isodir_adr]
|
|
if {$idx == -1} {
|
|
set isodir_return_name $isodir_adr
|
|
set isodir_adr "/"
|
|
} else {
|
|
if {$idx > 0} {
|
|
if {$idx < [expr $l - 1]} {
|
|
set isodir_return_name \
|
|
[string range $isodir_adr [expr $idx+1] end]
|
|
}
|
|
set isodir_adr [string range $isodir_adr 0 [expr $idx - 1]]
|
|
} else {
|
|
if {$l > 1} {
|
|
set isodir_return_name [string range $isodir_adr 1 end]
|
|
}
|
|
set isodir_adr "/"
|
|
}
|
|
}
|
|
isodir_return "isodir_up"
|
|
}
|
|
|
|
|
|
# Rename resp. move the files which are selected in the .isolist box.
|
|
# The target is defined by the .isomanip_move_target text field.
|
|
# Called when the "Move to:" button is hit.
|
|
#
|
|
proc isomanip_mv {} {
|
|
global .isolist
|
|
global isomanip_move_target isolist_names isodir_is_pwd isodir_adr
|
|
global isodir_return_name
|
|
|
|
if {$isomanip_move_target == ""} {
|
|
xorriso_tcltk_errmsg \
|
|
"xorriso-tcltk : SORRY : First you must enter a target address"
|
|
return ""
|
|
}
|
|
set selected [.isolist curselection]
|
|
set num_selected [llength $selected]
|
|
if {$num_selected < 1} {
|
|
xorriso_tcltk_errmsg \
|
|
"xorriso-tcltk : SORRY : First you must select one or more ISO files"
|
|
return ""
|
|
}
|
|
|
|
set target $isomanip_move_target
|
|
if {$isodir_is_pwd == 0 && [string range $target 0 0] != "/"} {
|
|
set target [combine_dir_and_name $isodir_adr $target]
|
|
}
|
|
set target_ftype [get_iso_filetype $target]
|
|
|
|
# If more than one selected : target must be directory
|
|
if {$num_selected > 1} {
|
|
if {$target_ftype != "d" && $target_ftype != ""} {
|
|
xorriso_tcltk_errmsg \
|
|
"xorriso-tcltk : SORRY : If multiple files are selected then the target must be a directory"
|
|
return ""
|
|
}
|
|
if {$target_ftype == ""} {
|
|
set isomanip_move_target_mem $isomanip_move_target
|
|
set isomanip_move_target $target
|
|
isomanip_mkdir
|
|
set isomanip_move_target $isomanip_move_target_mem
|
|
}
|
|
}
|
|
|
|
enforce_overwrite_settings "isofs"
|
|
reset_highest_cmd_sev
|
|
reset_yesno_to_all
|
|
set multi_source 0
|
|
if {[llength $selected] != 1} {set multi_source 1}
|
|
foreach i $selected {
|
|
set name [lindex $isolist_names $i]
|
|
if {$isodir_is_pwd == 0} {
|
|
set name [combine_dir_and_name $isodir_adr $name]
|
|
}
|
|
set name_ftype [isofs_filetype $name]
|
|
|
|
# Ask for confirmation if overwriting is about to happen
|
|
if {$target_ftype == "d"} {
|
|
set eff_target [combine_dir_and_name $target $name]
|
|
set eff_target_ftype [get_iso_filetype $eff_target]
|
|
} else {
|
|
set eff_target $target
|
|
set eff_target_ftype $target_ftype
|
|
}
|
|
if {[handle_overwriting "isofs" $eff_target $eff_target_ftype \
|
|
"isofs" $name $name_ftype $multi_source \
|
|
"" ""] == "0"} {
|
|
if {$multi_source == 0} { return "" }
|
|
continue
|
|
}
|
|
send_loggable_cmd "-mv [make_text_shellsafe $name] [make_text_shellsafe $target] --"
|
|
}
|
|
|
|
if {[llength $selected] == 1} {
|
|
set isodir_return_name [path_touches_isodir $target]
|
|
}
|
|
browse_iso_refresh
|
|
isodir_return "isomanip_mv"
|
|
}
|
|
|
|
|
|
# Create an empty ISO directory with address given by variable
|
|
# isomanip_move_target.
|
|
# Called when the "Make dir" button is hit or by other functions.
|
|
#
|
|
proc isomanip_mkdir {} {
|
|
global isomanip_move_target isodir_adr isodir_return_name
|
|
|
|
if {$isomanip_move_target == ""} {
|
|
xorriso_tcltk_errmsg \
|
|
"xorriso-tcltk : SORRY : First you must enter a target address"
|
|
return ""
|
|
}
|
|
|
|
if {[string range $isomanip_move_target 0 0] == "/"} {
|
|
set abs_adr $isomanip_move_target
|
|
} else {
|
|
set abs_adr [combine_dir_and_name $isodir_adr $isomanip_move_target]
|
|
}
|
|
reset_highest_cmd_sev
|
|
send_loggable_cmd "-mkdir [make_text_shellsafe $abs_adr] --"
|
|
|
|
# Refresh only if new dir in isodir_adr
|
|
# or if a parent directory of new dir is created in isodir_adr
|
|
set touch_name [path_touches_isodir $abs_adr]
|
|
if {$touch_name != ""} {
|
|
if {[llength [.isolist curselection]] != 0} {
|
|
memorize_isolist_selection
|
|
set selection_memorized 1
|
|
} else {
|
|
set isodir_return_name $touch_name
|
|
set selection_memorized 0
|
|
}
|
|
isodir_return "isomanip_mkdir"
|
|
if {$selection_memorized != 0} {
|
|
restore_isolist_selection
|
|
}
|
|
}
|
|
browse_iso_refresh
|
|
}
|
|
|
|
|
|
# Remove a file or directory tree from the ISO image.
|
|
# Called when the "Delete" button is hit.
|
|
#
|
|
proc isomanip_rm_r {} {
|
|
global .isolist
|
|
global isomanip_move_target isolist_names isodir_is_pwd isodir_adr
|
|
|
|
set selected [.isolist curselection]
|
|
if {[llength $selected] < 1} {
|
|
xorriso_tcltk_errmsg \
|
|
"xorriso-tcltk : SORRY : First you must select one or more ISO files"
|
|
return ""
|
|
}
|
|
if {[window_yesno "Really delete the selected files from ISO image ?"] \
|
|
!= 1} { return "" }
|
|
reset_highest_cmd_sev
|
|
foreach i $selected {
|
|
set name [lindex $isolist_names $i]
|
|
if {$isodir_is_pwd == 0} {
|
|
set name [combine_dir_and_name $isodir_adr $name]
|
|
}
|
|
send_loggable_cmd "-rm_r [make_text_shellsafe $name] --"
|
|
}
|
|
browse_iso_refresh
|
|
isodir_return "isomanip_rm_r"
|
|
}
|
|
|
|
|
|
# Perform a blanking run on the output drive.
|
|
# Called when the "Blank" button is hit.
|
|
#
|
|
proc burn_blank {} {
|
|
global outdev_adr outdev_profile
|
|
|
|
if {[assert_outdev blanking] <= 0} {return ""}
|
|
|
|
set victim "medium in"
|
|
if {[string first "stdio" $outdev_profile] == 0} {
|
|
set victim "image file"
|
|
}
|
|
if {[window_yesno \
|
|
"Really blank the $victim [make_text_shellsafe $outdev_adr] ?"] \
|
|
!= 1} { return "" }
|
|
reset_highest_cmd_sev
|
|
send_loggable_cmd "-blank as_needed"
|
|
refresh_indev
|
|
refresh_outdev
|
|
}
|
|
|
|
|
|
# Perform a formatting run on the output drive.
|
|
# Called when the "Format" button is hit.
|
|
#
|
|
proc burn_format {} {
|
|
global outdev_adr outdev_profile
|
|
|
|
if {[assert_outdev formatting] <= 0} {return ""}
|
|
|
|
if {[string first "stdio" $outdev_profile] == 0} {
|
|
xorriso_tcltk_errmsg \
|
|
"xorriso-tcltk : SORRY : Image files cannot be formatted"
|
|
return ""
|
|
}
|
|
if {[window_yesno "Really format the medium in $outdev_adr ?"] \
|
|
!= 1} { return "" }
|
|
|
|
reset_highest_cmd_sev
|
|
send_loggable_cmd "-format as_needed"
|
|
refresh_indev
|
|
refresh_outdev
|
|
}
|
|
|
|
|
|
# Write pending changes in the xorriso ISO model as session to the output
|
|
# drive. This will be an add-on session if the drive is output and input drive
|
|
# and if its medium is not blank.
|
|
# Else it will be a new independent ISO image.
|
|
#
|
|
proc burn_commit {} {
|
|
global outdev_adr result_list result_count outdev_medium_status
|
|
global burn_write_close burn_write_tao burn_write_defect_mgt
|
|
global indev_adr outdev_adr permission_policy
|
|
|
|
if {[assert_outdev "writing an ISO session"] <= 0} {return ""}
|
|
if {$outdev_adr == $indev_adr} {
|
|
if {$outdev_medium_status != "blank" && \
|
|
$outdev_medium_status != "appendable"} {
|
|
xorriso_tcltk_errmsg \
|
|
"xorriso-tcltk : SORRY : Medium in output drive is neither blank nor appendable"
|
|
return ""
|
|
}
|
|
} else {
|
|
if {$outdev_medium_status != "blank"} {
|
|
xorriso_tcltk_errmsg \
|
|
"xorriso-tcltk : SORRY : Medium in output drive is not blank"
|
|
return ""
|
|
}
|
|
}
|
|
if {[changes_are_pending] == "0"} {
|
|
window_ack "No changes are pending. Will not write ISO session." \
|
|
"grey" "toplevel"
|
|
return ""
|
|
}
|
|
if {$outdev_adr == $indev_adr} {
|
|
if {[window_yesno "Really write ISO changes as session to $outdev_adr ?"] \
|
|
!= 1} { return "" }
|
|
} else {
|
|
if {[window_yesno "Really write a new ISO filesystem to $outdev_adr ?"] \
|
|
!= 1} { return "" }
|
|
}
|
|
|
|
reset_highest_cmd_sev
|
|
effectuate_permission_policy
|
|
set cmd "-close"
|
|
if {$burn_write_close == 1} {
|
|
set cmd "$cmd on"
|
|
} else {
|
|
set cmd "$cmd off"
|
|
}
|
|
set cmd "$cmd -write_type"
|
|
if {$burn_write_tao == 1} {
|
|
set cmd "$cmd tao"
|
|
} else {
|
|
set cmd "$cmd auto"
|
|
}
|
|
set cmd "$cmd -stream_recording"
|
|
if {$burn_write_defect_mgt == 1} {
|
|
set cmd "$cmd off"
|
|
} else {
|
|
set cmd "$cmd data"
|
|
}
|
|
set cmd "$cmd -commit"
|
|
send_loggable_cmd $cmd
|
|
refresh_indev
|
|
refresh_outdev
|
|
}
|
|
|
|
|
|
# Verify the MD5 checksums of the data files in the tree underneath the
|
|
# current ISO directory.
|
|
# Called when the "Verify" in the "ISO directory:" line is hit.
|
|
#
|
|
proc isodir_verify {} {
|
|
global isodir_adr
|
|
|
|
reset_highest_cmd_sev
|
|
send_loggable_cmd "-check_md5_r sorry [make_text_shellsafe $isodir_adr] --"
|
|
|
|
# >>> select mismatching files or directories with mismatching files
|
|
|
|
}
|
|
|
|
|
|
# Verify the MD5 checksums of the data files orch are selected or which
|
|
# sit in the trees underneath the selected items in the isolist box.
|
|
# Called when the "Verify" in the "Selection:" line is hit.
|
|
#
|
|
proc isomanip_verify {} {
|
|
global .isolist
|
|
global isomanip_move_target isolist_names isodir_is_pwd isodir_adr
|
|
|
|
set selected [.isolist curselection]
|
|
if {[llength $selected] < 1} {
|
|
xorriso_tcltk_errmsg \
|
|
"xorriso-tcltk : SORRY : First you must select one or more ISO files"
|
|
return ""
|
|
}
|
|
reset_highest_cmd_sev
|
|
foreach i $selected {
|
|
set name [combine_dir_and_name $isodir_adr \
|
|
[lindex $isolist_names $i]]
|
|
send_loggable_cmd "-check_md5_r sorry [make_text_shellsafe $name] --"
|
|
}
|
|
|
|
# >>> select mismatching files or directories with mismatching files
|
|
|
|
}
|
|
|
|
|
|
# Slow down the spinning of the aquired optical drives.
|
|
# Called when button "Calm drives" is hit.
|
|
#
|
|
proc calm_drives {} {
|
|
reset_highest_cmd_sev
|
|
send_loggable_cmd "-calm_drive all"
|
|
}
|
|
|
|
|
|
# Burn a data file from disk as session to the output drive.
|
|
# Called when the "Burn image file:" button is hit.
|
|
#
|
|
proc burn_write_image {} {
|
|
global burn_write_image_adr burn_write_close outdev_adr outdev_medium_status
|
|
global outdev_profile burn_write_tao burn_write_defect_mgt indev_adr
|
|
|
|
update_dev_var
|
|
if {$indev_adr != ""} {
|
|
xorriso_tcltk_errmsg \
|
|
"xorriso-tcltk : SORRY : You may not have an input drive open when writing an image file"
|
|
return ""
|
|
}
|
|
|
|
if {[assert_outdev "writing an image file"] <= 0} {return ""}
|
|
if {$burn_write_image_adr == ""} {
|
|
xorriso_tcltk_errmsg \
|
|
"xorriso-tcltk : SORRY : You have to set an image file address in the hard disk filesystem first"
|
|
return ""
|
|
}
|
|
|
|
if {$outdev_medium_status != "blank"} {
|
|
xorriso_tcltk_errmsg \
|
|
"xorriso-tcltk : SORRY : You must have a blank medium in the output drive for burning an image data file"
|
|
return ""
|
|
}
|
|
if {[file readable $burn_write_image_adr] == 0 || \
|
|
[file isfile $burn_write_image_adr] == 0 ||
|
|
[file exists $burn_write_image_adr] == 0} {
|
|
xorriso_tcltk_errmsg \
|
|
"xorriso-tcltk : SORRY : Image file '$burn_write_image_adr' is not a readable data file"
|
|
return ""
|
|
}
|
|
if {[window_yesno "Really write '$burn_write_image_adr' as image to $outdev_adr ?"] \
|
|
!= 1} { return "" }
|
|
|
|
set cmd "-as cdrecord -v"
|
|
if {[regexp "^CD" $outdev_profile] == 1 && \
|
|
( $outdev_medium_status == "appendable" || $burn_write_tao == 1 )} {
|
|
set cmd "$cmd padsize=150s"
|
|
}
|
|
set cmd "$cmd dev=[make_text_shellsafe $outdev_adr]"
|
|
set cmd "$cmd [make_text_shellsafe $burn_write_image_adr]"
|
|
if {$burn_write_tao == 1} {
|
|
set cmd "$cmd -tao"
|
|
}
|
|
if {$burn_write_close != 1} {
|
|
set cmd "$cmd -multi"
|
|
}
|
|
if {$burn_write_defect_mgt == 1} {
|
|
set cmd "$cmd stream_recording=off"
|
|
} else {
|
|
set cmd "$cmd stream_recording=32s"
|
|
}
|
|
reset_highest_cmd_sev
|
|
send_loggable_cmd $cmd
|
|
refresh_state
|
|
}
|
|
|
|
|
|
# Discard all image modifications and reload ISO image model from input drive.
|
|
# Called when the "Rollback" button is hit.
|
|
#
|
|
proc iso_rollback {} {
|
|
if {[window_yesno \
|
|
"Really discard all pending changes and reload from input drive ?"] \
|
|
!= 1} { return "" }
|
|
reset_highest_cmd_sev
|
|
send_loggable_cmd "-rollback"
|
|
.avail_label configure -text ""
|
|
isodir_return "iso_rollback"
|
|
}
|
|
|
|
|
|
# Inquire an accurate prediction of free space after writing a session with
|
|
# the pending changes of the ISO image.
|
|
# Called when button "Refresh avail:" is hit.
|
|
#
|
|
proc refresh_avail {} {
|
|
global result_list highest_cmd_sev
|
|
global sieve_ret
|
|
|
|
if {[assert_outdev "refreshing available space prediction"] <= 0} {return ""}
|
|
|
|
set line "n.a."
|
|
reset_highest_cmd_sev
|
|
clear_sieve
|
|
send_marked_cmd "-tell_media_space"
|
|
if {[compare_sev $highest_cmd_sev "FAILURE"] < 0} {
|
|
set ac ""
|
|
read_sieve "After commit :"
|
|
if {$sieve_ret > 0} {
|
|
set ac [lindex $result_list 0]
|
|
set ac [string range $ac 0 [expr [string length $ac] - 2]]
|
|
set line "[format "%7dm" [expr "$ac / 512"]]"
|
|
}
|
|
}
|
|
.avail_label configure -text $line
|
|
}
|
|
|
|
|
|
# Warn and prompt the user for confirmation if there is the risk to overwrite
|
|
# existing files on hard disk or in the ISO image model.
|
|
# Called from several procedures which cause side effects on directory trees.
|
|
#
|
|
proc handle_overwriting {target_fs target target_ftype
|
|
source_fs source source_ftype multi_source
|
|
selected_adr selected_ftype} {
|
|
global overwrite_iso_files overwrite_iso_dirs overwrite_disk_files
|
|
|
|
if {$target_fs == "localfs"} {
|
|
set to_fs "hard disk"
|
|
set overwrite_fs "disk"
|
|
set overwrite_dirs 0
|
|
set overwrite_files $overwrite_disk_files
|
|
} else {
|
|
set to_fs "ISO"
|
|
set overwrite_fs "ISO"
|
|
set overwrite_dirs $overwrite_iso_dirs
|
|
set overwrite_files $overwrite_iso_files
|
|
}
|
|
if {$source_fs == "localfs"} {
|
|
set from_fs "hard disk"
|
|
} else {
|
|
set from_fs "ISO"
|
|
}
|
|
if {$multi_source == 1} {
|
|
set what_window window_yesno_ever
|
|
} else {
|
|
set what_window window_yesno
|
|
}
|
|
|
|
# >>> Nicer would be:
|
|
# >>> Check if any file will get overwritten. Not only the direct target.
|
|
# >>> Then silently allow directories to be merged
|
|
|
|
if {$target_ftype != ""} {
|
|
if {$target_ftype == "d"} {
|
|
if {$source_ftype == "d"} {
|
|
if {[$what_window \
|
|
"Really merge existing $to_fs directory\n\n[make_text_shellsafe $target]\n\nwith $from_fs directory\n[make_text_shellsafe $source]\n?"] \
|
|
!= 1} { return "0" }
|
|
} else {
|
|
if {$target_fs != "isofs"} {
|
|
xorriso_tcltk_errmsg "xorriso-tcltk : SORRY : Will not replace directories on hard disk by file of other type"
|
|
return "0"
|
|
}
|
|
if {$overwrite_dirs == 1} {
|
|
if {[$what_window \
|
|
"Really overwrite $to_fs directory\n\n[make_text_shellsafe $target]\n\nby $from_fs file\n[make_text_shellsafe $source]\n?"] \
|
|
!= 1} { return "0" }
|
|
} else {
|
|
xorriso_tcltk_errmsg "xorriso-tcltk : SORRY : You would have to enable \"Overwrite $overwrite_fs dirs\""
|
|
return "0"
|
|
}
|
|
}
|
|
} else {
|
|
if {$overwrite_files == 1} {
|
|
if {[$what_window \
|
|
"Really overwrite $to_fs file\n\n[make_text_shellsafe $target]\n\nby $from_fs file\n[make_text_shellsafe $source]\n?"] != 1} {
|
|
return "0"
|
|
}
|
|
} else {
|
|
xorriso_tcltk_errmsg "xorriso-tcltk : SORRY : You would have to enable \"Overwrite $overwrite_fs files\""
|
|
return "0"
|
|
}
|
|
}
|
|
}
|
|
if {$selected_adr != $target && $selected_adr != "" && \
|
|
$selected_ftype != "d" && $selected_ftype != ""} {
|
|
if {[$what_window \
|
|
"Really replace existing $to_fs file\n\n[make_text_shellsafe $target]\n\nby $from_fs directory\n[make_text_shellsafe $source]\n?"] != 1} {
|
|
return "0"
|
|
}
|
|
}
|
|
return "1"
|
|
}
|
|
|
|
|
|
# Insert a file or directory tree into the ISO model tree and schedule it
|
|
# for being copied when "Write ISO session" is hit.
|
|
# Called when button "Insert from disk:" is hit.
|
|
#
|
|
proc insert_from {} {
|
|
global insert_from_adr isodir_adr isolist_names isodir_return_name
|
|
global insert_at_selected insert_underneath
|
|
|
|
if {[assert_iso_image 1] == 0} {return ""}
|
|
if {$insert_from_adr == ""} {
|
|
xorriso_tcltk_errmsg \
|
|
"xorriso-tcltk : SORRY : You have to set a source address in the hard disk filesystem first"
|
|
return ""
|
|
}
|
|
set selected_ftype ""
|
|
set selected_adr ""
|
|
if {$insert_at_selected == 1} {
|
|
set selected [.isolist curselection]
|
|
if {[llength $selected] != 1} {
|
|
xorriso_tcltk_errmsg "xorriso-tcltk : SORRY : You must select exactly one ISO file as insertion target"
|
|
return ""
|
|
}
|
|
set target "[lindex $isolist_names [lindex $selected 0]]"
|
|
set selected_ftype [get_iso_filetype $target]
|
|
set selected_adr $target
|
|
} else {
|
|
set target $isodir_adr
|
|
}
|
|
set source_ftype [localfs_filetype $insert_from_adr]
|
|
set name [file tail $insert_from_adr]
|
|
if {$insert_underneath == 1 || $source_ftype == "d"} {
|
|
set target [combine_dir_and_name $target $name]
|
|
}
|
|
set target_ftype [get_iso_filetype $target]
|
|
|
|
reset_yesno_to_all
|
|
if {[handle_overwriting "isofs" $target $target_ftype \
|
|
"localfs" $insert_from_adr $source_ftype 0 \
|
|
$selected_adr $selected_ftype] == "0"} {
|
|
return ""
|
|
}
|
|
|
|
set preserve_selection 0
|
|
if {$insert_underneath + $insert_at_selected == 1} {
|
|
set isodir_return_name $name
|
|
} else {
|
|
set preserve_selection 1
|
|
}
|
|
reset_highest_cmd_sev
|
|
enforce_overwrite_settings "isofs"
|
|
send_loggable_cmd "-map [make_text_shellsafe $insert_from_adr] [make_text_shellsafe $target]"
|
|
|
|
if {$preserve_selection == 1} {
|
|
memorize_isolist_selection
|
|
}
|
|
isodir_return "insert_from"
|
|
if {$preserve_selection == 1} {
|
|
restore_isolist_selection
|
|
}
|
|
browse_iso_refresh
|
|
}
|
|
|
|
|
|
# Copy a file out of the ISO image model to the hard disk filesystem.
|
|
# The meta data stem from the ISO model tree. The content data are usually
|
|
# read from the input drive.
|
|
# Called when button "Extract to disk:" is hit.
|
|
#
|
|
proc extract_to {} {
|
|
global extract_to_adr extract_from_selected extract_underneath
|
|
global extract_auto_chmod osirrox_allowed
|
|
global isodir_adr isolist_names
|
|
|
|
if {$osirrox_allowed != 1} {
|
|
xorriso_tcltk_errmsg \
|
|
"xorriso-tcltk : SORRY : Extraction from ISO to hard disk is irrevocably banned."
|
|
return ""
|
|
}
|
|
|
|
if {[assert_iso_image 1] == 0} {return ""}
|
|
if {$extract_to_adr == ""} {
|
|
xorriso_tcltk_errmsg \
|
|
"xorriso-tcltk : SORRY : You have to set a target address in the hard disk filesystem first"
|
|
return ""
|
|
}
|
|
set sources ""
|
|
set selected_ftype ""
|
|
set selected_adr ""
|
|
if {$extract_from_selected == 1} {
|
|
set selected [.isolist curselection]
|
|
if {[llength $selected] < 1} {
|
|
xorriso_tcltk_errmsg "xorriso-tcltk : SORRY : You must select at least one ISO file as extraction source"
|
|
return ""
|
|
}
|
|
foreach i $selected {
|
|
set path [combine_dir_and_name $isodir_adr \
|
|
[lindex $isolist_names $i]]
|
|
lappend sources $path
|
|
}
|
|
} else {
|
|
set sources [list $isodir_adr]
|
|
}
|
|
|
|
reset_highest_cmd_sev
|
|
reset_yesno_to_all
|
|
enforce_overwrite_settings "localfs"
|
|
set disp_en_mem [set_display_msg 0]
|
|
if {$extract_auto_chmod == 1} {
|
|
send_loggable_cmd "-osirrox on:sort_lba_on:auto_chmod_on"
|
|
} else {
|
|
send_loggable_cmd "-osirrox on:sort_lba_off:auto_chmod_off"
|
|
}
|
|
set_display_msg $disp_en_mem
|
|
set multi_source 0
|
|
if {[llength $sources] != 1} {set multi_source 1}
|
|
foreach i $sources {
|
|
if {$extract_underneath == 1} {
|
|
set name [file tail $i]
|
|
set target [combine_dir_and_name $extract_to_adr $name]
|
|
} else {
|
|
if {[llength $sources] != 1} {
|
|
xorriso_tcltk_errmsg "xorriso-tcltk : SORRY : You must select exactly one ISO file as extraction source"
|
|
return ""
|
|
}
|
|
set target $extract_to_adr
|
|
}
|
|
if {$i == ""} {
|
|
set i "/"
|
|
}
|
|
set target_ftype [localfs_filetype $target]
|
|
set from_is_dir 0
|
|
set source_ftype [isofs_filetype $i]
|
|
if {[handle_overwriting "localfs" $target $target_ftype \
|
|
"isofs" $i $source_ftype $multi_source \
|
|
"" ""] == 0} {
|
|
continue
|
|
}
|
|
send_loggable_cmd \
|
|
"-extract [make_text_shellsafe $i] [make_text_shellsafe $target]"
|
|
}
|
|
browse_tree_populate "localfs"
|
|
}
|
|
|
|
|
|
# Send the currently chosen -overwrite settings of the checkbuttons
|
|
# "Overwrite ISO files", "Overwrite ISO dirs", "Overwrite hard disk files".
|
|
# Called before operations which could overwrite files in ISO model
|
|
# or in the hard disk filesystem.
|
|
# I.e. any -overwrite command sent via the "Command:" text field will not
|
|
# be able to override the checkbuttons.
|
|
#
|
|
proc enforce_overwrite_settings {which_fs} {
|
|
global overwrite_iso_files overwrite_iso_dirs overwrite_disk_files
|
|
|
|
if {$which_fs == "isofs"} {
|
|
if {$overwrite_iso_files == 0} {
|
|
set mode "off"
|
|
} else {
|
|
if {$overwrite_iso_dirs == 0} {
|
|
set mode "nondir"
|
|
} else {
|
|
set mode "on"
|
|
}
|
|
}
|
|
} else {
|
|
if {$overwrite_disk_files == 1} {
|
|
set mode "on"
|
|
} else {
|
|
set mode "off"
|
|
}
|
|
}
|
|
set disp_en_mem [set_display_msg 0]
|
|
send_loggable_cmd "-overwrite $mode"
|
|
set_display_msg $disp_en_mem
|
|
}
|
|
|
|
|
|
# Send xorriso an appropriate end command and wait for the pipes to break.
|
|
# Called when button "End" is hit.
|
|
#
|
|
proc end_xorriso {} {
|
|
global expect_broken_pipes
|
|
|
|
if {[window_yesno "Really end this program and its xorriso backend ?"] \
|
|
!= 1} { return "" }
|
|
if {[changes_are_pending] == 1} {
|
|
if {[window_yesno \
|
|
"Changes of the ISO image are pending.\nReally discard them ?"] \
|
|
!= 1} { return "" }
|
|
set expect_broken_pipes "1"
|
|
send_loggable_cmd "-rollback_end"
|
|
} else {
|
|
set expect_broken_pipes "1"
|
|
send_loggable_cmd "-end"
|
|
}
|
|
central_exit 0
|
|
}
|
|
|
|
|
|
# Check whether an output drive is aquired. Propose refusal if not.
|
|
# Called by procedures which are about to use the output drive.
|
|
#
|
|
proc assert_outdev {purpose} {
|
|
global outdev_adr
|
|
|
|
if {$outdev_adr == ""} {
|
|
xorriso_tcltk_errmsg \
|
|
"xorriso-tcltk : SORRY : You must choose an output drive before $purpose"
|
|
return "0"
|
|
}
|
|
return "1"
|
|
}
|
|
|
|
|
|
# Check whether changes to the ISO model are pending. If so, propose refusal.
|
|
# Called by procedures which are about to discard the ISO model.
|
|
#
|
|
proc assert_no_changes {} {
|
|
if {[changes_are_pending] == 1} {
|
|
window_ack "ISO image changes are pending. You have to do \"Write ISO session\" or \"Rollback\"." "grey" "toplevel"
|
|
return "0"
|
|
}
|
|
return "1"
|
|
}
|
|
|
|
|
|
# Set the text of the "Permissions:" menubutton
|
|
# Called by the radiobuttons in the menu.
|
|
#
|
|
proc show_permission_policy {} {
|
|
global permission_policy
|
|
|
|
set text $permission_policy
|
|
if {$permission_policy == "as_is"} {
|
|
set text "as is"
|
|
}
|
|
if {$permission_policy == "mkisofs_r"} {
|
|
set text "mkisofs -r"
|
|
}
|
|
.perm_policy configure -text "Permissions: $text"
|
|
}
|
|
|
|
|
|
# Set the target address of command logging.
|
|
# Called by the "Script/Log" menu.
|
|
#
|
|
proc set_log_script_address {} {
|
|
browse_tree cmd_log_target "localfs"
|
|
set w .browse_disk_window
|
|
tkwait window $w
|
|
effectuate_command_logging 0
|
|
}
|
|
|
|
|
|
# Bring into effect the settings for command script logging.
|
|
# Called by the "Accept" button or the Return key of the
|
|
# "Set log script address" file browser.
|
|
#
|
|
proc effectuate_command_logging {close_window} {
|
|
global cmd_log_target cmd_logging_mode browse_disk_window_is_active
|
|
|
|
if {$close_window == 1 && $browse_disk_window_is_active == 1} {
|
|
destroy_browse_disk .browse_disk_window
|
|
}
|
|
if {$close_window == 1 || $cmd_logging_mode > 0} {
|
|
start_command_logging $cmd_log_target $cmd_logging_mode
|
|
}
|
|
}
|
|
|
|
|
|
# Set the target address of communication pipe logging.
|
|
# Called by the "Script/Log" menu.
|
|
#
|
|
proc set_debug_log_address {} {
|
|
browse_tree debug_log_file "localfs"
|
|
set w .browse_disk_window
|
|
tkwait window $w
|
|
effectuate_debug_logging 0
|
|
}
|
|
|
|
|
|
# Bring into effect the settings for communication pipe logging.
|
|
# Called by the "Accept" button or the Return key of the
|
|
# "Set pipe log address" file browser.
|
|
#
|
|
proc effectuate_debug_logging {close_window} {
|
|
global debug_log_file debug_logging browse_disk_window_is_active
|
|
|
|
if {$close_window == 1 && $browse_disk_window_is_active == 1} {
|
|
destroy_browse_disk .browse_disk_window
|
|
}
|
|
if {$close_window == 1 || $debug_logging > 0} {
|
|
start_debug_logging $debug_log_file $debug_logging
|
|
}
|
|
}
|
|
|
|
|
|
# Trigger execution of a script of xorriso commands.
|
|
# Called by the "Script/Log" menu.
|
|
#
|
|
proc start_script_execution {} {
|
|
browse_tree execute_script_adr "localfs"
|
|
# actual script start is done by browse_tree_accept -> execute_script
|
|
}
|
|
|
|
|
|
# Permanently ban any extraction from ISO to hard disk
|
|
#
|
|
proc osirrox_banned {} {
|
|
global osirrox_allowed
|
|
|
|
reset_yesno_to_all
|
|
if {[window_yesno \
|
|
"Really irrevocably ban any extraction from ISO to hard disk ?"] \
|
|
!= 1} { return "" }
|
|
|
|
send_loggable_cmd "-osirrox banned"
|
|
set osirrox_allowed 0
|
|
}
|
|
|
|
|
|
# ------ A primitive file tree browser for hard disk filesystem and ISO model
|
|
|
|
# Write a directory content list into a Tree widget
|
|
#
|
|
proc browse_tree_fill_dir {tr parent children} {
|
|
|
|
if {$parent == "/"} {
|
|
set parent_name root
|
|
} else {
|
|
set parent_name $parent
|
|
}
|
|
if {[$tr exists $parent_name] == 0} {return ""}
|
|
|
|
$tr delete [$tr nodes $parent_name]
|
|
|
|
foreach i $children {
|
|
set name [string range $i 2 end]
|
|
set adr [combine_dir_and_name $parent $name]
|
|
$tr insert end $parent_name $adr -text $name
|
|
if {[string range $i 0 0] == "d"} {
|
|
set dir_dummy [combine_dir_and_name $adr "_"]
|
|
$tr insert end $adr $dir_dummy -text " "
|
|
}
|
|
}
|
|
}
|
|
|
|
|
|
# The command to be executed when the user selects a node.
|
|
#
|
|
proc browse_tree_select {adr_var_name tr selected} {
|
|
global browse_select_is_setvar
|
|
|
|
if {$browse_select_is_setvar == 0} {return ""}
|
|
browse_tree_accept $adr_var_name 0 $tr $selected
|
|
}
|
|
|
|
|
|
# The command to be executed when the user double-clicks a node.
|
|
#
|
|
proc browse_tree_accept {adr_var_name do_return tr selected} {
|
|
global extract_to_adr insert_from_adr burn_write_image_adr isodir_adr
|
|
global isomanip_move_target indev_adr outdev_adr cmd_log_target
|
|
global debug_log_file execute_script_adr
|
|
|
|
if {[llength $selected] == 0} {
|
|
set value ""
|
|
} else {
|
|
set value [lindex $selected 0]
|
|
}
|
|
if {$adr_var_name == "burn_write_image_adr"} {
|
|
set burn_write_image_adr $value
|
|
if {$do_return == 1} {burn_write_image}
|
|
}
|
|
if {$adr_var_name == "extract_to_adr"} {
|
|
set extract_to_adr $value
|
|
if {$do_return == 1} {extract_to}
|
|
}
|
|
if {$adr_var_name == "insert_from_adr"} {
|
|
set insert_from_adr $value
|
|
if {$do_return == 1} {insert_from}
|
|
}
|
|
if {$adr_var_name == "isodir_adr"} {
|
|
set isodir_adr $value
|
|
if {$do_return == 1} {isodir_return "browse_tree_select"}
|
|
}
|
|
if {$adr_var_name == "isomanip_move_target"} {
|
|
set isomanip_move_target $value
|
|
if {$do_return == 1} {isomanip_mv}
|
|
}
|
|
if {$adr_var_name == "indev_adr"} {
|
|
set indev_adr $value
|
|
if {$do_return == 1} {indev_return}
|
|
}
|
|
if {$adr_var_name == "outdev_adr"} {
|
|
set outdev_adr $value
|
|
if {$do_return == 1} {outdev_return}
|
|
}
|
|
if {$adr_var_name == "cmd_log_target"} {
|
|
set cmd_log_target $value
|
|
if {$do_return == 1} {effectuate_command_logging 1}
|
|
}
|
|
if {$adr_var_name == "debug_log_file"} {
|
|
set debug_log_file $value
|
|
if {$do_return == 1} {effectuate_debug_logging 1}
|
|
}
|
|
if {$adr_var_name == "execute_script_adr"} {
|
|
set execute_script_adr $value
|
|
if {$do_return == 1} {execute_script 1}
|
|
}
|
|
}
|
|
|
|
|
|
# Translate a browser tree variable in a human readable topic text
|
|
#
|
|
proc browse_tree_topic {adr_var_name} {
|
|
if {$adr_var_name == "burn_write_image_adr"} {
|
|
return "Burn image file:"
|
|
}
|
|
if {$adr_var_name == "extract_to_adr"} {
|
|
return "Extract to disk:"
|
|
}
|
|
if {$adr_var_name == "insert_from_adr"} {
|
|
return "Insert from disk:"
|
|
}
|
|
if {$adr_var_name == "isodir_adr"} {
|
|
return "ISO directory:"
|
|
}
|
|
if {$adr_var_name == "isomanip_move_target"} {
|
|
return "Move to:"
|
|
}
|
|
if {$adr_var_name == "indev_adr"} {
|
|
return "Input drive/image"
|
|
}
|
|
if {$adr_var_name == "outdev_adr"} {
|
|
return "Output drive/image"
|
|
}
|
|
if {$adr_var_name == "cmd_log_target"} {
|
|
return "Set log script address"
|
|
}
|
|
if {$adr_var_name == "debug_log_file"} {
|
|
return "Set pipe log address"
|
|
}
|
|
if {$adr_var_name == "execute_script_adr"} {
|
|
return "Execute command script"
|
|
}
|
|
return $adr_var_name
|
|
}
|
|
|
|
|
|
# Accept the single selected item of the tree browser
|
|
# Called by the \"Accept\" button in the browser window.
|
|
#
|
|
proc browse_tree_accept_sel {adr_var_name do_return tr} {
|
|
set selected [$tr selection get]
|
|
if {[llength $selected] != 1} {
|
|
xorriso_tcltk_errmsg "xorriso-tcltk : SORRY : You must select a single tree item before clicking the \"Accept\" button."
|
|
return ""
|
|
}
|
|
browse_tree_accept $adr_var_name $do_return $tr $selected
|
|
}
|
|
|
|
|
|
# Hit the Return key on the text entry of the browser
|
|
#
|
|
proc browse_tree_accept_entry {adr_var_name do_return tr} {
|
|
global extract_to_adr insert_from_adr burn_write_image_adr isodir_adr
|
|
global isomanip_move_target indev_adr outdev_adr cmd_log_target
|
|
global debug_log_file execute_script_adr
|
|
|
|
eval set text $$adr_var_name
|
|
set selected [list $text]
|
|
browse_tree_accept $adr_var_name $do_return $tr $selected
|
|
}
|
|
|
|
|
|
# Move up one directory level of the file browser selection
|
|
#
|
|
proc browse_tree_up {adr_var_name tr which_fs} {
|
|
global extract_to_adr insert_from_adr burn_write_image_adr isodir_adr
|
|
global isomanip_move_target indev_adr outdev_adr
|
|
|
|
set selected [$tr selection get]
|
|
if {[llength $selected] != 1} {
|
|
xorriso_tcltk_errmsg "xorriso-tcltk : SORRY : You must select a single tree item before clicking the \"Up\" button."
|
|
return ""
|
|
}
|
|
set adr [file dirname [lindex $selected 0]]
|
|
eval set mem $$adr_var_name
|
|
set $adr_var_name $adr
|
|
browse_tree_populate $which_fs
|
|
set $adr_var_name $mem
|
|
if {$adr != "/" && $adr != ""} {
|
|
$tr selection clear
|
|
$tr selection set $adr
|
|
}
|
|
}
|
|
|
|
|
|
# Move down one directory level of the file browser selection
|
|
#
|
|
proc browse_tree_down {adr_var_name tr which_fs} {
|
|
global extract_to_adr insert_from_adr burn_write_image_adr isodir_adr
|
|
global isomanip_move_target indev_adr outdev_adr
|
|
|
|
set selected [$tr selection get]
|
|
if {[llength $selected] != 1} {
|
|
xorriso_tcltk_errmsg "xorriso-tcltk : SORRY : You must select a single tree item before clicking the \"Down\" button."
|
|
return ""
|
|
}
|
|
set adr [lindex $selected 0]
|
|
eval set mem $$adr_var_name
|
|
set $adr_var_name $adr
|
|
browse_tree_populate $which_fs
|
|
set $adr_var_name $mem
|
|
$tr selection set $adr
|
|
}
|
|
|
|
|
|
# The command to be executed when the user closes a directory node.
|
|
# It replaces the directory content list by a single dummy item.
|
|
#
|
|
proc browse_tree_close_dir {tr name} {
|
|
browse_tree_fill_dir $tr $name [list "? "]
|
|
}
|
|
|
|
|
|
# Delete the old content of the browse window and display the freshly
|
|
# obtained current state down to the current address in the field variable.
|
|
#
|
|
proc browse_tree_populate {which_fs} {
|
|
global browse_disk_window_var browse_iso_window_var
|
|
global browse_iso_window_is_active browse_disk_window_is_active
|
|
global extract_to_adr insert_from_adr burn_write_image_adr isodir_adr
|
|
global isomanip_move_target indev_adr outdev_adr cmd_log_target
|
|
global debug_log_file execute_script_adr
|
|
|
|
if {$which_fs == "isofs"} {
|
|
if {$browse_iso_window_is_active == 0} {return ""}
|
|
set w {.browse_iso_window}
|
|
set open_dir_cmd "browse_iso_open_dir"
|
|
set adr_var $browse_iso_window_var
|
|
} else {
|
|
if {$browse_disk_window_is_active == 0} {return ""}
|
|
set w {.browse_disk_window}
|
|
set open_dir_cmd "browse_disk_open_dir"
|
|
set adr_var $browse_disk_window_var
|
|
}
|
|
|
|
# Variable indirection
|
|
eval set adr $$adr_var
|
|
|
|
# Install root level
|
|
$open_dir_cmd $w.tree "/"
|
|
|
|
# Set $adr as current address
|
|
set comps [split $adr "/"]
|
|
# Install the stack of directories above current address
|
|
set path "/"
|
|
foreach i $comps {
|
|
if {$i == ""} {
|
|
continue
|
|
}
|
|
set path [combine_dir_and_name $path $i]
|
|
$open_dir_cmd $w.tree $path
|
|
catch {
|
|
$w.tree opentree $path 0
|
|
$w.tree see $path
|
|
}
|
|
}
|
|
}
|
|
|
|
|
|
# The procedure to be run by mouse button 3 in the file browser.
|
|
# It has to strip off the surplus parameter added by the Tree widget.
|
|
#
|
|
proc browse_tree_help {about_what button_color from_item} {
|
|
window_help $about_what $button_color
|
|
}
|
|
|
|
|
|
# Destroy the hard disk browser pop-up window.
|
|
#
|
|
proc destroy_browse_disk {w} {
|
|
global browse_disk_window_is_active browse_disk_window_geometry
|
|
global browse_disk_window_is_grabbed
|
|
|
|
if {$w != "" && $browse_disk_window_is_active == 1} {
|
|
if {$browse_disk_window_is_grabbed == 1} {
|
|
grab release $w
|
|
}
|
|
set browse_disk_window_is_grabbed 0
|
|
set browse_disk_window_geometry [wm geometry $w]
|
|
destroy $w
|
|
}
|
|
set browse_disk_window_is_active 0
|
|
}
|
|
|
|
|
|
# The command to be executed when the user opens a directory node in
|
|
# the hard disk filesystem.
|
|
#
|
|
proc browse_disk_open_dir {tr name} {
|
|
if {[localfs_filetype $name] != "d"} {return ""}
|
|
set lslist [localfs_ls $name]
|
|
browse_tree_fill_dir $tr $name $lslist
|
|
}
|
|
|
|
|
|
# Refresh the content of a possibly displayed tree browser for hard disk
|
|
#
|
|
proc browse_disk_refresh {} {
|
|
browse_tree_populate "localfs"
|
|
}
|
|
|
|
|
|
# The command to be executed when the user opens a directory node in
|
|
# the ISO model.
|
|
#
|
|
proc browse_iso_open_dir {tr name} {
|
|
if {[isofs_filetype $name] != "d"} {return ""}
|
|
set lslist [isofs_ls $name]
|
|
browse_tree_fill_dir $tr $name $lslist
|
|
}
|
|
|
|
|
|
# Destroy the ISO browser pop-up window.
|
|
#
|
|
proc destroy_browse_iso {w} {
|
|
global browse_iso_window_is_active browse_iso_window_geometry
|
|
global browse_iso_window_is_grabbed
|
|
|
|
if {$w != "" && $browse_iso_window_is_active == 1} {
|
|
set browse_iso_window_geometry [wm geometry $w]
|
|
if {$browse_iso_window_is_grabbed == 1} {
|
|
grab release $w
|
|
}
|
|
set browse_iso_window_is_grabbed 0
|
|
destroy $w
|
|
}
|
|
set browse_iso_window_is_active 0
|
|
}
|
|
|
|
|
|
# Refresh the content of a possibly displayed tree browser for ISO model
|
|
#
|
|
proc browse_iso_refresh {} {
|
|
browse_tree_populate "isofs"
|
|
}
|
|
|
|
|
|
# Multiplexer for updating both vertical scrollbars
|
|
#
|
|
proc browse_tree_yscrollcommand {w arg1 arg2} {
|
|
$w.treescroll_y_l set $arg1 $arg2
|
|
$w.treescroll_y_r set $arg1 $arg2
|
|
}
|
|
|
|
|
|
# Open a file browser window for hard disk filesystem or ISO model
|
|
#
|
|
proc browse_tree {adr_var which_fs} {
|
|
upvar $adr_var adr
|
|
global have_bwidget browse_disk_window_is_active browse_iso_window_is_active
|
|
global browse_disk_window_var browse_iso_window_var
|
|
global tree_window_lines tree_window_width tree_window_button_width
|
|
global browse_disk_window_geometry browse_iso_window_geometry
|
|
|
|
set button_color "grey"
|
|
|
|
if {$which_fs == "isofs"} {
|
|
set w {.browse_iso_window}
|
|
set window_is_active $browse_iso_window_is_active
|
|
set title_name "xorriso-tcltk ISO model browser"
|
|
set open_dir_cmd "browse_iso_open_dir"
|
|
set destroy_cmd "destroy_browse_iso"
|
|
if {$browse_iso_window_var != $adr_var && $window_is_active == 1} {
|
|
destroy_browse_iso $w
|
|
set window_is_active 0
|
|
}
|
|
set browse_iso_window_var $adr_var
|
|
set old_geometry $browse_iso_window_geometry
|
|
set browse_iso_window_is_active 1
|
|
} else {
|
|
set w {.browse_disk_window}
|
|
set window_is_active $browse_disk_window_is_active
|
|
set title_name "xorriso-tcltk hard disk filesystem browser"
|
|
set open_dir_cmd "browse_disk_open_dir"
|
|
set destroy_cmd "destroy_browse_disk"
|
|
if {$browse_disk_window_var != $adr_var && $window_is_active == 1} {
|
|
destroy_browse_disk $w
|
|
set window_is_active 0
|
|
}
|
|
set browse_disk_window_var $adr_var
|
|
set old_geometry $browse_disk_window_geometry
|
|
set browse_disk_window_is_active 1
|
|
}
|
|
set re_use_widgets 0
|
|
if {$window_is_active == 0} {
|
|
toplevel $w -borderwidth 10 -class Browser
|
|
wm title $w $title_name
|
|
set_window_position $w $old_geometry
|
|
} else {
|
|
set re_use_widgets 1
|
|
}
|
|
if {$re_use_widgets == 0} {
|
|
|
|
if {$have_bwidget == 1} {
|
|
# BWidget Tree
|
|
frame $w.tree_frame
|
|
frame $w.tree_frame_x
|
|
Tree $w.tree -width $tree_window_width -height $tree_window_lines \
|
|
-opencmd "$open_dir_cmd $w.tree" \
|
|
-closecmd "browse_tree_close_dir $w.tree" \
|
|
-selectcommand "browse_tree_select $adr_var" \
|
|
-selectfill 1 \
|
|
-yscrollcommand "browse_tree_yscrollcommand $w" \
|
|
-xscrollcommand "$w.treescroll_x set"
|
|
|
|
# ??? why doesn't <Return> work ?
|
|
# $w.tree bindText <Return> "browse_tree_accept $adr_var 1 $w.tree"
|
|
|
|
# At least double-click does work
|
|
$w.tree bindText <Double-Button-1> "browse_tree_accept $adr_var 1 $w.tree"
|
|
|
|
$w.tree bindText <Button-3> {browse_tree_help "Browse tree" grey}
|
|
|
|
scrollbar $w.treescroll_y_l -command "$w.tree yview"
|
|
scrollbar $w.treescroll_y_r -command "$w.tree yview"
|
|
scrollbar $w.treescroll_x -orient horizontal -command "$w.tree xview "
|
|
pack $w.tree -in $w.tree_frame_x -side top -expand 1 -fill both
|
|
pack $w.treescroll_x -in $w.tree_frame_x -side top -expand 1 -fill x
|
|
pack $w.treescroll_y_l -in $w.tree_frame -side left -expand 1 -fill y
|
|
pack $w.tree_frame_x -in $w.tree_frame -side left -expand 1 -fill both
|
|
pack $w.treescroll_y_r -in $w.tree_frame -side left -expand 1 -fill y
|
|
|
|
frame $w.button_line
|
|
button $w.accept -text "Accept" -width $tree_window_button_width \
|
|
-command "browse_tree_accept_sel $adr_var 1 $w.tree"
|
|
bind_help $w.accept "Accept (browse tree)"
|
|
button $w.to_field -text "Edit" -width $tree_window_button_width \
|
|
-command "browse_tree_accept_sel $adr_var 0 $w.tree"
|
|
bind_help $w.to_field "Edit (browse tree)"
|
|
button $w.up -text "Up" -width $tree_window_button_width \
|
|
-command "browse_tree_up $adr_var $w.tree $which_fs"
|
|
bind_help $w.up "Up (browse tree)"
|
|
button $w.down -text "Down" -width $tree_window_button_width \
|
|
-command "browse_tree_down $adr_var $w.tree $which_fs"
|
|
bind_help $w.down "Down (browse tree)"
|
|
pack $w.up $w.down $w.accept $w.to_field \
|
|
-in $w.button_line -side left -expand 0
|
|
|
|
pack $w.tree_frame -side top -anchor w -expand 1 -fill both
|
|
} else {
|
|
frame $w.button_line
|
|
button $w.accept -text "Accept" -width $tree_window_button_width \
|
|
-command "browse_tree_accept_entry $adr_var 1 $w.tree"
|
|
bind_help $w.accept "Accept (browse tree)"
|
|
pack $w.accept -in $w.button_line -side left -expand 0
|
|
}
|
|
button $w.help -text "Help" -width $tree_window_button_width \
|
|
-command {window_help "Browse tree" grey}
|
|
bind_help $w.help "Browse tree"
|
|
button $w.close -text "Close" -width $tree_window_button_width \
|
|
-command "$destroy_cmd $w" \
|
|
-background $button_color
|
|
bind_help $w.close "Close (browse tree)"
|
|
pack $w.help $w.close \
|
|
-in $w.button_line -side left -expand 0
|
|
|
|
pack $w.button_line -side top -anchor center
|
|
|
|
frame $w.text_frame
|
|
label $w.topic -text "[browse_tree_topic $adr_var]"
|
|
bind_help $w.topic "Browse tree"
|
|
entry $w.text_entry -relief sunken -bd 1 -width 40 \
|
|
-textvariable $adr_var
|
|
bind_entry_keys $w.text_entry \
|
|
"browse_tree_accept_entry $adr_var 1 $w.tree"
|
|
bind_help $w.text_entry "Browse tree"
|
|
pack $w.topic -in $w.text_frame -side left
|
|
pack $w.text_entry -in $w.text_frame -side left -expand 1 -fill both
|
|
pack $w.text_frame -side top -expand 1 -fill both
|
|
}
|
|
raise $w
|
|
if {$have_bwidget == 1} {
|
|
browse_tree_populate $which_fs
|
|
focus $w.tree
|
|
}
|
|
}
|
|
|
|
|
|
# ------ GUI display procedures ----
|
|
|
|
|
|
# Display a message of xorriso or of this frontend in the .msglist box
|
|
#
|
|
proc display_msg {msg} {
|
|
global .msglist
|
|
global msglist_max_fill msglist_running pre_msglist display_msg_enabled
|
|
|
|
if {$display_msg_enabled == 0} {return ""}
|
|
if {$msg == "============================" || \
|
|
$msg == "==============================================================" || \
|
|
$msg == "enter option and arguments :"} {return ""}
|
|
|
|
if {$msglist_running == 0} {
|
|
lappend pre_msglist $msg
|
|
} else {
|
|
if {[.msglist index end] > $msglist_max_fill} {
|
|
.msglist delete 0 0
|
|
}
|
|
.msglist insert end [escape_newline $msg]
|
|
.msglist see [expr "[.msglist index end]-1"]
|
|
update idletasks
|
|
}
|
|
}
|
|
|
|
|
|
# Set whether messages submitted to proc display_message shall really show up
|
|
# This is used by callback procedures to hide auxilliary commands and lengthy
|
|
# reply messages from the user display.
|
|
#
|
|
proc set_display_msg {mode} {
|
|
global display_msg_enabled
|
|
|
|
set old $display_msg_enabled
|
|
if {$mode == "0"} {
|
|
set display_msg_enabled 0
|
|
} else {
|
|
set display_msg_enabled "1"
|
|
}
|
|
return $old
|
|
}
|
|
|
|
|
|
# Display a frontend error message in the .msglist box and by a pop-up window.
|
|
#
|
|
proc xorriso_tcltk_errmsg {msg} {
|
|
global highest_cmd_sev_msg
|
|
|
|
set highest_cmd_sev_msg [escape_newline $msg]
|
|
display_msg $msg
|
|
window_ack $msg "grey" "toplevel"
|
|
update idletasks
|
|
}
|
|
|
|
|
|
# Memorize the current selection in the .isolist box.
|
|
#
|
|
proc memorize_isolist_selection {} {
|
|
global memorized_isolist_selection isolist_names
|
|
global .isolist
|
|
|
|
set memorized_isolist_selection ""
|
|
set selected [.isolist curselection]
|
|
foreach i $selected {
|
|
lappend memorized_isolist_selection [lindex $isolist_names $i]
|
|
}
|
|
}
|
|
|
|
|
|
# Restore the memorized selection in the .isolist box as far as the
|
|
# names have survived in the meantime.
|
|
#
|
|
proc restore_isolist_selection {} {
|
|
global memorized_isolist_selection isolist_names
|
|
global .isolist
|
|
|
|
.isolist selection clear 0 end
|
|
foreach i $memorized_isolist_selection {
|
|
set idx [lsearch -exact $isolist_names $i]
|
|
if {$idx > -1} {
|
|
.isolist selection set $idx $idx
|
|
}
|
|
}
|
|
set memorized_isolist_selection ""
|
|
}
|
|
|
|
|
|
# Receive the answer of the yes/no window and destroy it.
|
|
#
|
|
proc destroy_yesno {w answer} {
|
|
global yesno_window_is_active answer_of_yesno yesno_window_geometry
|
|
global yesno_to_all
|
|
|
|
if {$w != ""} {
|
|
set yesno_window_geometry [wm geometry $w]
|
|
grab release $w
|
|
destroy $w
|
|
update idletasks
|
|
}
|
|
set yesno_window_is_active 0
|
|
set answer_of_yesno $answer
|
|
if {$answer == 2} {
|
|
set yesno_to_all 1
|
|
set answer_of_yesno 1
|
|
}
|
|
if {$answer == -1} {
|
|
set yesno_to_all -1
|
|
set answer_of_yesno 0
|
|
}
|
|
}
|
|
|
|
|
|
# Pop-up a window which asks for yes or no. Return 1 if answer is yes.
|
|
#
|
|
proc window_yesno {question} {
|
|
global answer_of_yesno yesno_window_is_active yesno_window_geometry
|
|
|
|
set w {.yesno_window}
|
|
if {$yesno_window_is_active == 1} {
|
|
set yesno_window_is_active [window_exists $w]
|
|
}
|
|
if {$yesno_window_is_active == 1} {
|
|
raise $w
|
|
xorriso_tcltk_errmsg "xorriso-tcltk : SORRY : You still need to answer an older yes/no question"
|
|
return "0"
|
|
}
|
|
set yesno_window_is_active 1
|
|
set answer_of_yesno ""
|
|
toplevel $w -borderwidth 20 -class Dialog
|
|
wm title $w "xorriso-tcltk yes/no"
|
|
set_window_position $w $yesno_window_geometry
|
|
label $w.question -text $question
|
|
button $w.yes -text "yes" -command "destroy_yesno $w 1" \
|
|
-borderwidth 4 -padx 20 -pady 20
|
|
bind_help $w.yes "yes/no"
|
|
button $w.no -text "no" -command "destroy_yesno $w 0" \
|
|
-borderwidth 4 -padx 20 -pady 20
|
|
bind_help $w.no "yes/no"
|
|
pack $w.yes $w.question $w.no -side left
|
|
update idletasks
|
|
|
|
grab set $w
|
|
tkwait variable answer_of_yesno
|
|
return $answer_of_yesno
|
|
}
|
|
|
|
|
|
# Pop-up a window which asks for yes, yes-to-all, no, or no-to-all.
|
|
# Return 1 if answer is yes.
|
|
#
|
|
proc window_yesno_ever {question} {
|
|
global answer_of_yesno yesno_window_is_active yesno_window_geometry
|
|
global yesno_to_all
|
|
|
|
set w {.yesno_window}
|
|
if {$yesno_window_is_active == 1} {
|
|
set yesno_window_is_active [window_exists $w]
|
|
}
|
|
if {$yesno_window_is_active == 1} {
|
|
raise $w
|
|
xorriso_tcltk_errmsg "xorriso-tcltk : SORRY : You still need to answer an older yes/no question"
|
|
return "0"
|
|
}
|
|
if {$yesno_to_all == 1} {
|
|
return "1"
|
|
}
|
|
if {$yesno_to_all == -1} {
|
|
return "0"
|
|
}
|
|
set yesno_window_is_active 1
|
|
set answer_of_yesno ""
|
|
toplevel $w -borderwidth 20 -class Dialog
|
|
wm title $w "xorriso-tcltk yes/no"
|
|
set_window_position $w $yesno_window_geometry
|
|
|
|
frame $w.yes_frame
|
|
frame $w.no_frame
|
|
label $w.question -text $question
|
|
button $w.yes -text "yes" -command "destroy_yesno $w 1" \
|
|
-borderwidth 4 -padx 20 -pady 20 -relief raised
|
|
button $w.no -text "no" -command "destroy_yesno $w 0" \
|
|
-borderwidth 4 -padx 20 -pady 20 -relief raised
|
|
button $w.yes_to_all -text "yes to all" -command "destroy_yesno $w 2"
|
|
bind_help $w.yes_to_all "yes to all"
|
|
button $w.no_to_all -text "no to all" -command "destroy_yesno $w -1"
|
|
bind_help $w.no_to_all "no to all"
|
|
pack $w.yes $w.yes_to_all -in $w.yes_frame -side top -expand 1 -fill both
|
|
pack $w.no $w.no_to_all -in $w.no_frame -side top -expand 1 -fill both
|
|
pack $w.yes_frame $w.question $w.no_frame \
|
|
-in $w -side left -expand 1 -fill both
|
|
|
|
raise $w
|
|
update idletasks
|
|
|
|
grab set $w
|
|
tkwait variable answer_of_yesno
|
|
return $answer_of_yesno
|
|
}
|
|
|
|
|
|
proc reset_yesno_to_all {} {
|
|
global yesno_to_all
|
|
|
|
set yesno_to_all 0
|
|
}
|
|
|
|
|
|
# Destroy the notification pop-up window.
|
|
#
|
|
proc destroy_ack {w had_focus} {
|
|
global ack_window_is_active ack_window_geometry
|
|
|
|
if {$w != ""} {
|
|
set ack_window_geometry [wm geometry $w]
|
|
grab release $w
|
|
if {$had_focus != "-"} {
|
|
focus $had_focus
|
|
}
|
|
destroy $w
|
|
update idletasks
|
|
}
|
|
set ack_window_is_active 0
|
|
}
|
|
|
|
|
|
# Pop-up a window which notifies of a problem and asks for a button click.
|
|
#
|
|
proc window_ack {question button_color where} {
|
|
global answer_of_yesno ack_window_is_active ack_window_geometry
|
|
global continue_from_ack
|
|
|
|
set had_focus [focus]
|
|
if {$had_focus == ""} {set had_focus "-"}
|
|
set re_use_widgets 0
|
|
if {$where == "embedded"} {
|
|
set w ""
|
|
set destroy_cmd ""
|
|
} else {
|
|
set w {.ack_window}
|
|
if {$ack_window_is_active == 1} {
|
|
set ack_window_is_active [window_exists $w]
|
|
}
|
|
if {$ack_window_is_active == 0} {
|
|
toplevel $w -borderwidth 20 -class Dialog
|
|
wm title $w "xorriso-tcltk acknowledge"
|
|
set ack_window_is_active 1
|
|
} else {
|
|
set re_use_widgets 1
|
|
}
|
|
set_window_position $w $ack_window_geometry
|
|
set destroy_cmd "destroy_ack $w $had_focus"
|
|
}
|
|
if {$re_use_widgets == 1} {
|
|
$w.question configure -text $question
|
|
} else {
|
|
label $w.question -text $question
|
|
button $w.ok -text "Continue" -command $destroy_cmd \
|
|
-background $button_color
|
|
bind $w.ok <Return> $destroy_cmd
|
|
bind_help $w.ok "Continue"
|
|
pack $w.question -side top -expand 1 -fill both
|
|
pack $w.ok -side top
|
|
}
|
|
|
|
raise $w
|
|
update idletasks
|
|
focus $w.ok
|
|
grab set $w
|
|
tkwait variable ack_window_is_active
|
|
}
|
|
|
|
|
|
# Destroy the help pop-up window.
|
|
#
|
|
proc destroy_help {w help_main} {
|
|
global help_window_is_active help_window_has_scroll help_window_geometry
|
|
global main_help_window_is_active main_help_window_geometry
|
|
|
|
if {$w != ""} {
|
|
if {$help_main == 1} {
|
|
set main_help_window_geometry [wm geometry $w]
|
|
} else {
|
|
set help_window_geometry [wm geometry $w]
|
|
}
|
|
destroy $w
|
|
}
|
|
if {$help_main == 1} {
|
|
set main_help_window_is_active 0
|
|
} else {
|
|
set help_window_is_active 0
|
|
set help_window_has_scroll 0
|
|
}
|
|
}
|
|
|
|
|
|
proc surround_text {text} {
|
|
return "\n\n [string map {\n "\n "} $text]\n"
|
|
}
|
|
|
|
|
|
# Pop-up a window which shows a help text and a Close button.
|
|
#
|
|
proc window_help {about_what button_color} {
|
|
global help_window_is_active help_window_lines help_window_has_scroll
|
|
global help_window_border_width help_window_geometry
|
|
global main_help_window_is_active
|
|
global main_help_window_lines main_help_window_geometry
|
|
global .help_window .main_help_window
|
|
|
|
# The main help window is independent of the GUI element help window
|
|
if {$about_what == "Help"} {
|
|
set help_main 1
|
|
set w {.main_help_window}
|
|
set window_is_active $main_help_window_is_active
|
|
set window_has_scroll 1
|
|
set old_geometry $main_help_window_geometry
|
|
set window_lines $main_help_window_lines
|
|
} else {
|
|
set help_main 0
|
|
set w {.help_window}
|
|
set window_is_active $help_window_is_active
|
|
set window_has_scroll $help_window_has_scroll
|
|
set old_geometry $help_window_geometry
|
|
set window_lines $help_window_lines
|
|
}
|
|
if {$window_is_active == 1} {
|
|
set window_is_active [window_exists $w]
|
|
}
|
|
|
|
# Giving the help text some distance from the border decorations
|
|
set line_width 82
|
|
set helptext "\n\n [string map {\n "\n "} [tell_helptext $about_what]]\n"
|
|
|
|
if {[count_newlines $helptext] >= $window_lines} {
|
|
if {$window_is_active == 1 && $window_has_scroll == 0} {
|
|
destroy_help $w $help_main
|
|
set window_is_active 0
|
|
}
|
|
if {$help_main == 1} {
|
|
set old_geometry $main_help_window_geometry
|
|
} else {
|
|
set help_window_has_scroll 1
|
|
set window_has_scroll 1
|
|
set old_geometry $help_window_geometry
|
|
}
|
|
}
|
|
# Dealing with initiating windows that are grabbed
|
|
set grabbed [grab current]
|
|
if {$grabbed == ""} {set grabbed "-"}
|
|
if {$grabbed != "-" && $window_is_active == 1} {
|
|
destroy_help $w $help_main
|
|
set window_is_active 0
|
|
}
|
|
if {$grabbed != "-"} {
|
|
# Set old_geometry to position underneath grabbed window
|
|
set value [wm geometry $grabbed]
|
|
set idx [string first "+" $value]
|
|
set height_idx [string first "x" $value]
|
|
if {$idx != -1 && $height_idx != -1 && $idx > $height_idx} {
|
|
set width [string range $value 0 [expr $height_idx-1]]
|
|
set height [string range $value [expr $height_idx+1] [expr $idx-1]]
|
|
set x [string range $value [expr $idx+1] end]
|
|
set idx [string first "+" $x]
|
|
if {$idx != -1} {
|
|
set y [string range $x [expr $idx+1] end]
|
|
set x [string range $x 0 [expr $idx-1]]
|
|
set y [expr $y+$height]
|
|
set old_geometry "${width}x${height}+${x}+${y}"
|
|
}
|
|
}
|
|
}
|
|
|
|
set re_use_widgets 0
|
|
if {$window_is_active == 0} {
|
|
toplevel $w -borderwidth $help_window_border_width -class Help
|
|
set_window_position $w $old_geometry
|
|
if {$help_main == 1} {
|
|
wm title $w "xorriso-tcltk main help text"
|
|
set main_help_window_is_active 1
|
|
reset_to_normal_background .help
|
|
update idletasks
|
|
} else {
|
|
wm title $w "xorriso-tcltk GUI element help text"
|
|
set help_window_is_active 1
|
|
}
|
|
} else {
|
|
set re_use_widgets 1
|
|
}
|
|
|
|
if {$re_use_widgets == 1} {
|
|
$w.text configure -state normal
|
|
$w.text delete 1.0 end
|
|
$w.text insert end $helptext
|
|
raise $w
|
|
} else {
|
|
set destroy_cmd "destroy_help $w $help_main"
|
|
|
|
frame $w.text_frame
|
|
text $w.text -width $line_width -height $window_lines \
|
|
-relief flat -borderwidth 0
|
|
$w.text insert end $helptext
|
|
pack $w.text -in $w.text_frame -side left -expand 1 -fill both
|
|
if {$window_has_scroll == 1} {
|
|
scrollbar $w.scroll_y -command "$w.text yview"
|
|
$w.text configure -yscrollcommand "$w.scroll_y set"
|
|
bind_listbox_keys $w.text $window_lines "text"
|
|
pack $w.scroll_y -in $w.text_frame -side left -fill y
|
|
}
|
|
|
|
button $w.close -text "Close" -command $destroy_cmd \
|
|
-background $button_color
|
|
pack $w.text_frame -side top -expand 1 -fill both
|
|
frame $w.middle_spacer -height 6
|
|
frame $w.bottom_spacer -height 6
|
|
pack $w.middle_spacer $w.close $w.bottom_spacer -side top
|
|
}
|
|
$w.text configure -state disabled
|
|
}
|
|
|
|
|
|
# Display the busy/ready state of xorriso.
|
|
# Called with 1 by sender of commands and with 0 by receivers of replies .
|
|
#
|
|
proc display_busy {state} {
|
|
global busy_text_exists
|
|
global .busy_text
|
|
|
|
if {$busy_text_exists == 0} {return ""}
|
|
|
|
if {$state == 0} {
|
|
.busy_text configure -text "ready"
|
|
.busy_text configure -background "#D0D0D0"
|
|
} else {
|
|
.busy_text configure -text "busy"
|
|
.busy_text configure -background "#808080"
|
|
}
|
|
update idletasks
|
|
}
|
|
|
|
|
|
# Tries to make use of the BWidget package for getting its Tree widget
|
|
#
|
|
proc check_for_bwidget {} {
|
|
global have_bwidget bwidget_version
|
|
|
|
if {$have_bwidget == 0} {
|
|
catch {
|
|
set bwidget_version [package require BWidget]
|
|
set have_bwidget 1
|
|
}
|
|
}
|
|
}
|
|
|
|
|
|
# A window to display if no file browser is available
|
|
#
|
|
proc browser_dummy {} {
|
|
window_ack \
|
|
"The file browser cannot be used because Tcl/Tk package \"BWidget\" is not loaded" "grey" "toplevel"
|
|
}
|
|
|
|
|
|
# Obtain the geometry string of a window
|
|
#
|
|
proc get_window_geometry {w} {
|
|
wm geometry $w
|
|
}
|
|
|
|
|
|
# Set the position of a window from a geometry string
|
|
#
|
|
proc set_window_position {w geometry} {
|
|
set value $geometry
|
|
set idx [string first "+" $value]
|
|
if {$idx == -1} {
|
|
set value [wm geometry .]
|
|
set idx [string first "+" $value]
|
|
}
|
|
if {$idx == -1} { return "" }
|
|
set pos [string range $value $idx end]
|
|
wm geometry $w $pos
|
|
}
|
|
|
|
|
|
# Reset button appearance from startup color to normal color
|
|
#
|
|
proc reset_to_normal_background {w} {
|
|
set normal_color [.drive_drop_both cget -background]
|
|
$w configure -background $normal_color
|
|
}
|
|
|
|
|
|
# Checks whether a window is really there
|
|
#
|
|
proc window_exists {w} {
|
|
set window_exists 0
|
|
catch {
|
|
$w cget -background
|
|
set window_exists 1
|
|
}
|
|
return $window_exists
|
|
}
|
|
|
|
|
|
# ------ Building GUI components ------
|
|
|
|
# ------ GUI layout parameters ------
|
|
|
|
# The default position of the main window
|
|
set main_window_geometry ""
|
|
|
|
# How to mark the borders of the main grouping frames
|
|
set main_framerelief ridge
|
|
set main_borderwidth 4
|
|
|
|
# How to mark the borders of the second level grouping frames
|
|
set borderwidth 1
|
|
|
|
# Number of lines in msglist display
|
|
set msglist_lines 8
|
|
set msglist_max_fill 1000
|
|
set msglist_running 0
|
|
|
|
# Number of lines in drivelist display
|
|
set drivelist_lines 2
|
|
|
|
# Number of lines in ISO directory content display
|
|
set isolist_lines 8
|
|
|
|
# Whether the message box shall export its selection to the whole X display
|
|
set export_msg_selection true
|
|
|
|
# Wether the item lists shall export their selection
|
|
set export_selection false
|
|
|
|
# The number of lines in the display of the help texts
|
|
set main_help_window_lines 24
|
|
set help_window_lines 16
|
|
|
|
# The distance of the help text from the help window border
|
|
set help_window_border_width 0
|
|
|
|
# The number of items to display in a tree browser window
|
|
set tree_window_lines 12
|
|
# The number of visible characters in a tree browser line
|
|
set tree_window_width 50
|
|
# The width in characters of the six buttons under the tree browser
|
|
set tree_window_button_width 6
|
|
|
|
|
|
# -------- GUI definition procedures
|
|
|
|
|
|
# Overall definition of the GUI
|
|
#
|
|
proc init_gui {} {
|
|
global .input .cmdline_entry .msgbox .errmsg .dev .drivebox
|
|
global .isobox .localfs
|
|
global main_framerelief main_borderwidth click_to_focus
|
|
|
|
check_for_bwidget
|
|
|
|
# Main grouping frames
|
|
frame .connection_block \
|
|
-relief $main_framerelief -borderwidth $main_borderwidth
|
|
frame .drive_block \
|
|
-relief $main_framerelief -borderwidth $main_borderwidth
|
|
frame .iso_block \
|
|
-relief $main_framerelief -borderwidth $main_borderwidth
|
|
|
|
init_input
|
|
init_msgbox
|
|
init_errmsg
|
|
init_dev
|
|
init_drivebox
|
|
init_isobox
|
|
init_isomanip
|
|
init_burn
|
|
init_localfs
|
|
|
|
pack .input .msgbox .errmsg -in .connection_block \
|
|
-side top -expand 1 -fill both
|
|
pack .drivebox .dev .burn -in .drive_block \
|
|
-side top -expand 1 -fill both
|
|
pack .localfs .isobox .isomanip -in .iso_block \
|
|
-side top -expand 1 -fill both
|
|
|
|
pack .connection_block .drive_block .iso_block \
|
|
-side top -expand 1 -fill both
|
|
|
|
if {$click_to_focus == 1} {
|
|
focus .msglist
|
|
}
|
|
}
|
|
|
|
|
|
# The xorriso headline with End button, xorriso version, busy/ready indicator,
|
|
# command line, and "Refresh disp" button.
|
|
#
|
|
proc init_input {} {
|
|
global borderwidth busy_text_exists xorriso_version debug_logging
|
|
global cmd_logging_mode cmd_log_target
|
|
global .input .input_line1 .xorriso_version .busy .busy_text
|
|
global .refresh_state .end_button .cmdline .log_pipes_switch
|
|
|
|
frame .input -borderwidth $borderwidth
|
|
frame .input_line1 -borderwidth 0
|
|
pack .input_line1 -in .input \
|
|
-side top -anchor w -expand 1 -fill both
|
|
|
|
button .end_button -text "End" -command "end_xorriso"
|
|
bind_help .end_button "End"
|
|
|
|
if {[string length $xorriso_version] > 10} {
|
|
set xorriso_version [string range $xorriso_version 0 9]
|
|
}
|
|
label .xorriso_version -text "xorriso-$xorriso_version"
|
|
bind_help .xorriso_version "version"
|
|
frame .busy -relief ridge -borderwidth 2
|
|
label .busy_text -width 5 -text "busy"
|
|
bind_help .busy_text "ready/busy"
|
|
set busy_text_exists 1
|
|
pack .busy_text -in .busy
|
|
|
|
button .refresh_state -text "Refresh disp" \
|
|
-command "refresh_state"
|
|
bind_help .refresh_state "Refresh disp"
|
|
|
|
menubutton .script_log -text "Script/Log" -anchor w \
|
|
-direction below -relief ridge -indicatoron 1 \
|
|
-menu .script_log.menu
|
|
bind_help .script_log "Script/Log"
|
|
set m ".script_log.menu"
|
|
menu $m
|
|
$m add checkbutton -label "Log command script" \
|
|
-indicatoron 1 -selectcolor "" \
|
|
-command "effectuate_command_logging 0" \
|
|
-variable cmd_logging_mode \
|
|
-onvalue 1 -offvalue 0
|
|
$m add command -label "Set log script address" \
|
|
-command "set_log_script_address"
|
|
$m add separator
|
|
$m add checkbutton -label "Log pipes" \
|
|
-indicatoron 1 -selectcolor "" \
|
|
-variable debug_logging \
|
|
-onvalue 1 -offvalue 0
|
|
$m add command -label "Set pipe log address" \
|
|
-command "set_debug_log_address"
|
|
$m add separator
|
|
$m add separator
|
|
$m add command -label "Execute command script" \
|
|
-command "start_script_execution"
|
|
$m add checkbutton -label "Allow extract to disk" \
|
|
-indicatoron 1 -selectcolor "" \
|
|
-variable script_with_osirrox \
|
|
-onvalue 1 -offvalue 0
|
|
$m add separator
|
|
$m add command -label "Permanently ban extraction" \
|
|
-command "osirrox_banned"
|
|
|
|
button .help -text "Help" -command {window_help "Help" "grey"} \
|
|
-background "grey"
|
|
bind_help .help "Help"
|
|
|
|
init_cmdline
|
|
|
|
pack .end_button .xorriso_version .busy -in .input_line1 -side left
|
|
pack .cmdline \
|
|
-in .input_line1 -side left -expand 1 -fill both
|
|
pack .refresh_state .script_log .help -in .input_line1 -side left
|
|
}
|
|
|
|
|
|
# The combination of "Command:" label and command line
|
|
#
|
|
proc init_cmdline {} {
|
|
global cmdline borderwidth
|
|
global .cmdline .cmdline_text .cmdline_entry
|
|
|
|
frame .cmdline -borderwidth 0
|
|
|
|
label .cmdline_text -width 10 -text "Command:"
|
|
bind_help .cmdline_text "Command:"
|
|
entry .cmdline_entry -width 56 -relief sunken -bd 1 \
|
|
-textvariable cmdline
|
|
bind_entry_keys .cmdline_entry {cmdline_return}
|
|
bind_help .cmdline_entry "Command:"
|
|
|
|
# >>> is there a chance to get a history on an entry ?
|
|
|
|
pack .cmdline_text -in .cmdline -side left
|
|
pack .cmdline_entry -in .cmdline -side left -expand 1 -fill both
|
|
}
|
|
|
|
|
|
# The listbox where to display commands and reply messages unless this is
|
|
# disabled for auxiliary commands which shall not clutter the display.
|
|
#
|
|
proc init_msgbox {} {
|
|
global borderwidth
|
|
global msglist_lines export_msg_selection msglist_running pre_msglist
|
|
global .msgbox .msglist .msgscroll
|
|
|
|
frame .msgbox -borderwidth $borderwidth
|
|
|
|
listbox .msglist -height $msglist_lines -selectmode extended \
|
|
-yscrollcommand ".msgscroll set" \
|
|
-exportselection $export_msg_selection
|
|
bind_listbox_keys ".msglist" $msglist_lines "listbox"
|
|
bind_help .msglist "message box"
|
|
set msglist_running 1
|
|
foreach i $pre_msglist {
|
|
display_msg [escape_newline $i]
|
|
}
|
|
scrollbar .msgscroll -command ".msglist yview"
|
|
pack .msglist -in .msgbox -side left -expand 1 -fill both
|
|
pack .msgscroll -in .msgbox -side right -fill y
|
|
set pre_msglist ""
|
|
}
|
|
|
|
|
|
# Two display lines for most severe event messages. One gets reset with
|
|
# each important command. The other one stays until the user clears it.
|
|
#
|
|
proc init_errmsg {} {
|
|
global borderwidth
|
|
global .errmsg .total_errmsg .cmd_errmsg
|
|
|
|
frame .errmsg -borderwidth $borderwidth
|
|
|
|
init_total_errmsg
|
|
init_cmd_errmsg
|
|
|
|
pack .cmd_errmsg .total_errmsg -in .errmsg \
|
|
-side top -anchor w -expand 1 -fill both
|
|
|
|
}
|
|
|
|
|
|
# The most severe message display which gets reset automatically.
|
|
#
|
|
proc init_cmd_errmsg {} {
|
|
global borderwidth
|
|
global .cmd_errmsg .cmd_errmsg_label .cmd_errmsg_msg
|
|
|
|
frame .cmd_errmsg -borderwidth $borderwidth
|
|
|
|
label .cmd_errmsg_label -width 14 -text "Recent problem:" -anchor w
|
|
bind_help .cmd_errmsg_label "Recent problem:"
|
|
label .cmd_errmsg_msg -width 80 -relief ridge -bd 2 \
|
|
-anchor w \
|
|
-textvariable highest_cmd_sev_msg
|
|
# (no keys, no focus)
|
|
bind_help .cmd_errmsg_msg "Recent problem:"
|
|
pack .cmd_errmsg_label -in .cmd_errmsg -side left
|
|
pack .cmd_errmsg_msg -in .cmd_errmsg -side left -expand 1 -fill both
|
|
}
|
|
|
|
|
|
# The persistent most severe message display that is to be reset by the user.
|
|
#
|
|
proc init_total_errmsg {} {
|
|
global borderwidth
|
|
global .total_errmsg .total_errmsg_label .total_errmsg_msg
|
|
global .total_errmsg_clear
|
|
|
|
frame .total_errmsg -borderwidth $borderwidth
|
|
|
|
label .total_errmsg_label -text "Worst problem:" -width 14 -anchor w
|
|
bind_help .total_errmsg_label "Worst problem:"
|
|
button .total_errmsg_clear -text "Clear" \
|
|
-width 5 \
|
|
-command "clear_total_errmsg"
|
|
bind_help .total_errmsg_clear "Clear"
|
|
label .total_errmsg_msg -width 80 -relief ridge -bd 2 \
|
|
-anchor w \
|
|
-textvariable highest_total_sev_msg
|
|
# (no keys, no focus)
|
|
bind_help .total_errmsg_msg "Worst problem:"
|
|
pack .total_errmsg_label -in .total_errmsg -side left
|
|
pack .total_errmsg_msg -in .total_errmsg -side left -expand 1 -fill both
|
|
pack .total_errmsg_clear -in .total_errmsg -side left
|
|
}
|
|
|
|
|
|
# The list of drives which were found by scanning, the Scan button, and
|
|
# buttons for picking a drive from the list, for giving them up, for
|
|
# calming them down, and for reloading the ISO image from the input drive.
|
|
#
|
|
proc init_drivebox {} {
|
|
global borderwidth drivelist_lines export_selection
|
|
global .drivebox .drivelistbox .drivelist .drivescroll .drive_scan
|
|
global .drive_picker .drive_scan .drive_pick_in .drive_pick_out
|
|
global .drive_pick_both .drive_drop_both .drive_calm .iso_rollback_button
|
|
|
|
|
|
frame .drivebox -borderwidth $borderwidth
|
|
frame .drivelistbox -borderwidth $borderwidth
|
|
listbox .drivelist -height $drivelist_lines -selectmode extended \
|
|
-yscrollcommand ".drivescroll set" \
|
|
-exportselection $export_selection
|
|
bind_listbox_keys ".drivelist" $drivelist_lines "listbox"
|
|
bind_help .drivelist "drivelist"
|
|
scrollbar .drivescroll -command ".drivelist yview"
|
|
|
|
pack .drivelist -in .drivelistbox -side left -expand 1 -fill both
|
|
pack .drivescroll -in .drivelistbox -side right -fill y
|
|
|
|
frame .drive_picker -borderwidth $borderwidth
|
|
frame .drive_picker_line_1 -borderwidth 0
|
|
frame .drive_picker_line_2 -borderwidth 0
|
|
frame .drive_aux_buttons_line_1 -borderwidth 0
|
|
frame .drive_aux_buttons_line_2 -borderwidth 0
|
|
frame .drive_aux_buttons -borderwidth 0
|
|
|
|
button .drive_scan -text "Scan for drives" \
|
|
-background "grey" \
|
|
-command "scan_for_drives"
|
|
bind_help .drive_scan "Scan for drives"
|
|
button .drive_pick_in -text "Pick input drive" \
|
|
-command "pick_indev"
|
|
bind_help .drive_pick_in "Pick input drive"
|
|
button .drive_pick_out -text "Pick output drive" \
|
|
-command "pick_outdev"
|
|
bind_help .drive_pick_out "Pick output drive"
|
|
button .drive_pick_both -text "Pick drive for both roles" \
|
|
-command "pick_dev"
|
|
bind_help .drive_pick_both "Pick drive for both roles"
|
|
button .drive_drop_both -text "Give up drives" \
|
|
-command "give_up_dev"
|
|
bind_help .drive_drop_both "Give up drives"
|
|
button .drive_calm -text "Calm drives" \
|
|
-command "calm_drives"
|
|
bind_help .drive_calm "Calm drives"
|
|
button .iso_rollback_button -text "Rollback" -width 9 \
|
|
-command {iso_rollback}
|
|
bind_help .iso_rollback_button "Rollback"
|
|
|
|
# One button block left, one right
|
|
pack .drive_pick_in .drive_pick_out \
|
|
-in .drive_picker_line_1 -side left -expand 1 -fill none
|
|
pack .drive_pick_both \
|
|
-in .drive_picker_line_2 -side left -expand 1 -fill x
|
|
pack .drive_picker_line_1 .drive_picker_line_2 \
|
|
-in .drive_picker -side top -expand 1 -fill x -anchor w
|
|
pack .drive_scan .drive_calm \
|
|
-in .drive_aux_buttons_line_1 -side left -expand 1 -fill none
|
|
pack .drive_drop_both .iso_rollback_button \
|
|
-in .drive_aux_buttons_line_2 -side left -expand 1 -fill x
|
|
pack .drive_aux_buttons_line_1 .drive_aux_buttons_line_2 \
|
|
-in .drive_aux_buttons -side top -expand 1 -fill x -anchor w
|
|
pack .drive_picker -in .drivebox -side left -expand 0 -fill none
|
|
pack .drivelistbox -in .drivebox -side left -expand 1 -fill both
|
|
pack .drive_aux_buttons -in .drivebox -side left -expand 0 -fill none
|
|
|
|
bind .drivelist <Double-Button-1> {
|
|
pick_dev
|
|
}
|
|
}
|
|
|
|
|
|
# The text fields for setting and display of the current input and output
|
|
# drives. With Eject button and a short text description of the medium status.
|
|
#
|
|
proc init_dev {} {
|
|
global borderwidth
|
|
global .dev .indev .outdev
|
|
|
|
frame .dev -borderwidth $borderwidth
|
|
|
|
init_indev
|
|
init_outdev
|
|
|
|
pack .indev .outdev -in .dev \
|
|
-side top -anchor w -expand 1 -fill both
|
|
}
|
|
|
|
|
|
# Set and display the current input drive.
|
|
#
|
|
proc init_indev {} {
|
|
global borderwidth indev_adr
|
|
global .indev .indev_eject .indev_label .indev_entry .indev_summary
|
|
|
|
frame .indev -borderwidth $borderwidth
|
|
|
|
button .indev_eject -text "Eject" -command {eject_indev}
|
|
bind_help .indev_eject "Eject (indev)"
|
|
label .indev_label -width 16 -text "Input drive/image "
|
|
bind_help .indev_label "Input drive/image"
|
|
entry .indev_entry -width 36 -relief sunken -bd 1 \
|
|
-textvariable indev_adr
|
|
|
|
bind_entry_keys .indev_entry {indev_return}
|
|
bind_help .indev_entry "Input drive/image"
|
|
label .indev_summary -width 60 -text "" -relief ridge -borderwidth 2
|
|
bind_help .indev_summary "input drive info"
|
|
create_browser_button .indev_browse_button \
|
|
"indev_adr" "localfs" "Browse disk (indev)"
|
|
|
|
pack .indev_eject .indev_label .indev_entry \
|
|
-in .indev -side left -expand 1 -fill both
|
|
pack .indev_browse_button -in .indev -side left
|
|
pack .indev_summary \
|
|
-in .indev -side left -expand 1 -fill both
|
|
}
|
|
|
|
|
|
# Set and display the current output drive.
|
|
#
|
|
proc init_outdev {} {
|
|
global .outdev .outdev_eject .outdev_label .outdev_entry .outdev_summary
|
|
global borderwidth outdev_adr
|
|
|
|
frame .outdev -borderwidth $borderwidth
|
|
|
|
button .outdev_eject -text "Eject" -command {eject_outdev}
|
|
bind_help .outdev_eject "Eject (outdev)"
|
|
label .outdev_label -width 16 -text "Output drive/image"
|
|
bind_help .outdev_label "Output drive/image"
|
|
entry .outdev_entry -width 36 -relief sunken -bd 1 \
|
|
-textvariable outdev_adr
|
|
bind_entry_keys .outdev_entry {outdev_return}
|
|
bind_help .outdev_entry "Output drive/image"
|
|
create_browser_button .outdev_browse_button \
|
|
"outdev_adr" "localfs" "Browse disk (outdev)"
|
|
label .outdev_summary -width 60 -text "" -relief ridge -borderwidth 2
|
|
bind_help .outdev_summary "output drive info"
|
|
pack .outdev_eject .outdev_label .outdev_entry \
|
|
-in .outdev -side left -expand 1 -fill both
|
|
pack .outdev_browse_button -in .outdev -side left
|
|
pack .outdev_summary \
|
|
-in .outdev -side left -expand 1 -fill both
|
|
}
|
|
|
|
|
|
# The button panel for blanking, formatting, and writing to the output drive.
|
|
#
|
|
proc init_burn {} {
|
|
global borderwidth burn_write_image_adr burn_write_close burn_write_tao
|
|
global burn_write_defect_mgt
|
|
global .burn .burn_blank_button .burn_format_button .burn_commit_button
|
|
global .burn_write_image .burn_write_image_entry .burn_write_close
|
|
global .burn_write_tao .burn_write_defect_mgt
|
|
|
|
frame .burn -borderwidth $borderwidth
|
|
|
|
button .burn_blank_button -text "Blank" \
|
|
-command {burn_blank}
|
|
bind_help .burn_blank_button "Blank"
|
|
button .burn_format_button -text "Format" \
|
|
-command {burn_format}
|
|
bind_help .burn_format_button "Format"
|
|
button .burn_commit_button -text "Write ISO session" \
|
|
-command {burn_commit}
|
|
bind_help .burn_commit_button "Write ISO session"
|
|
button .burn_write_image -text "Burn image file:" \
|
|
-command {burn_write_image}
|
|
bind_help .burn_write_image "Burn image file:"
|
|
entry .burn_write_image_entry -width 40 -relief sunken -bd 1 \
|
|
-textvariable burn_write_image_adr
|
|
bind_entry_keys .burn_write_image_entry {burn_write_image}
|
|
bind_help .burn_write_image_entry "Burn image file:"
|
|
create_browser_button .burn_image_browse_button \
|
|
"burn_write_image_adr" "localfs" "Browse disk (burn image)"
|
|
checkbutton .burn_write_close -text "Close" \
|
|
-indicatoron 1 -selectcolor "" \
|
|
-relief ridge -borderwidth 2 \
|
|
-variable burn_write_close \
|
|
-onvalue 1 -offvalue 0
|
|
bind_help .burn_write_close "Close"
|
|
checkbutton .burn_write_tao -text "TAO" \
|
|
-indicatoron 1 -selectcolor "" \
|
|
-relief ridge -borderwidth 2 \
|
|
-variable burn_write_tao \
|
|
-onvalue 1 -offvalue 0
|
|
bind_help .burn_write_tao "TAO"
|
|
checkbutton .burn_write_defect_mgt -text "Defect Mgt" \
|
|
-indicatoron 1 -selectcolor "" \
|
|
-relief ridge -borderwidth 2 \
|
|
-variable burn_write_defect_mgt \
|
|
-onvalue 1 -offvalue 0
|
|
bind_help .burn_write_defect_mgt "Defect Mgt"
|
|
pack .burn_blank_button .burn_format_button \
|
|
.burn_commit_button .burn_write_close .burn_write_tao \
|
|
.burn_write_defect_mgt \
|
|
.burn_write_image .burn_write_image_entry \
|
|
-in .burn -side left -expand 1 -fill both
|
|
pack .burn_image_browse_button -in .burn -side left
|
|
}
|
|
|
|
|
|
# Set and display the current ISO directory and its content.
|
|
#
|
|
proc init_isobox {} {
|
|
global borderwidth isolist_lines export_selection
|
|
global .isobox .isodir .isolist .isodir_entry .isodir_up .isodir_up2
|
|
global .isodir_label .isodir_verify .isolistbox .isoscroll_y .isoscroll_x
|
|
|
|
frame .isobox -borderwidth $borderwidth
|
|
frame .isodir -borderwidth 0
|
|
|
|
label .isodir_label -text "ISO directory:" \
|
|
-width 14
|
|
bind_help .isodir_label "ISO directory:"
|
|
entry .isodir_entry -width 60 -relief sunken -bd 1 \
|
|
-textvariable isodir_adr
|
|
bind_entry_keys .isodir_entry {isodir_return "isodir_entry"}
|
|
bind_help .isodir_entry "ISO directory:"
|
|
create_browser_button .isodir_browse_button \
|
|
"isodir_adr" "isofs" "Browse ISO (isodir)"
|
|
button .isodir_verify -text "Verify" -command {isodir_verify}
|
|
bind_help .isodir_verify "Verify"
|
|
button .isodir_up -text "Up" -command {isodir_up}
|
|
bind_help .isodir_up "Up"
|
|
button .isodir_up2 -text "Up" -command {isodir_up}
|
|
bind_help .isodir_up2 "Up"
|
|
pack .isodir_label .isodir_up \
|
|
-in .isodir -side left
|
|
pack .isodir_entry \
|
|
-in .isodir -side left -expand 1 -fill both
|
|
pack .isodir_browse_button .isodir_up2 .isodir_verify \
|
|
-in .isodir -side left
|
|
|
|
frame .isolistbox -borderwidth 0
|
|
listbox .isolist -height $isolist_lines -selectmode extended \
|
|
-yscrollcommand ".isoscroll_y set" \
|
|
-xscrollcommand ".isoscroll_x set" \
|
|
-exportselection $export_selection
|
|
bind_listbox_keys ".isolist" $isolist_lines "listbox"
|
|
bind_help .isolist "isolist"
|
|
scrollbar .isoscroll_y -command ".isolist yview"
|
|
scrollbar .isoscroll_x -orient horizontal -command ".isolist xview"
|
|
pack .isolist -in .isolistbox -side left -expand 1 -fill both
|
|
bind .isolist <Double-Button-1> { pick_isodir }
|
|
pack .isoscroll_y -in .isolistbox -side right -fill y
|
|
|
|
pack .isodir .isolistbox .isoscroll_x \
|
|
-in .isobox -side top -expand 1 -fill both
|
|
}
|
|
|
|
|
|
# The ISO-internal manipulation buttons for the ISO directory or its content.
|
|
# Plus a text field where to set an ISO path as target for renaming or
|
|
# directory making.
|
|
#
|
|
proc init_isomanip {} {
|
|
global borderwidth isomanip_move_target
|
|
global .isomanip .isomanip_move .isomanip_prefix .isomanip_verify_button
|
|
global .isomanip_move_target .isomanip_rm_r_button .isomanip_move_button
|
|
global .isomanip_mkdir_button .isomanip_move_target
|
|
global .avail_label .avail_label_frame .avail_button
|
|
|
|
frame .isomanip -borderwidth $borderwidth
|
|
frame .isomanip_move -borderwidth 0
|
|
|
|
label .isomanip_prefix -text "Selection:"
|
|
bind_help .isomanip_prefix "Selection:"
|
|
|
|
button .isomanip_verify_button -text "Verify" \
|
|
-command {isomanip_verify}
|
|
bind_help .isomanip_verify_button "Verify (selection)"
|
|
button .isomanip_rm_r_button -text "Delete" \
|
|
-command {isomanip_rm_r}
|
|
bind_help .isomanip_rm_r_button "Delete"
|
|
button .isomanip_move_button -text "Move to:" \
|
|
-command {isomanip_mv}
|
|
bind_help .isomanip_move_button "Move to:"
|
|
button .isomanip_mkdir_button -text "Make dir" \
|
|
-command {isomanip_mkdir}
|
|
bind_help .isomanip_mkdir_button "Make dir"
|
|
entry .isomanip_move_target -width 60 -relief sunken -bd 1 \
|
|
-textvariable isomanip_move_target
|
|
bind_entry_keys .isomanip_move_target {isomanip_mv}
|
|
bind_help .isomanip_move_target "rename and mkdir target"
|
|
create_browser_button .isomanip_move_target_button \
|
|
"isomanip_move_target" "isofs" "Browse ISO (move target)"
|
|
|
|
pack .isomanip_prefix .isomanip_verify_button .isomanip_rm_r_button \
|
|
.isomanip_move_button \
|
|
-in .isomanip_move -side left
|
|
pack .isomanip_move_target \
|
|
-in .isomanip_move -side left -expand 1 -fill both
|
|
pack .isomanip_move_target_button -in .isomanip_move -side left
|
|
pack .isomanip_mkdir_button \
|
|
-in .isomanip_move -side left -expand 1 -fill both
|
|
pack .isomanip_move \
|
|
-in .isomanip -side top -expand 1 -fill both
|
|
}
|
|
|
|
|
|
# The means for interaction of ISO image and hard disk filesystem.
|
|
#
|
|
proc init_localfs {} {
|
|
global borderwidth
|
|
global .localfs .extract_frame .aux_control_frame .insert_frame
|
|
|
|
frame .localfs -borderwidth $borderwidth
|
|
|
|
init_extract
|
|
init_aux_control
|
|
init_insert
|
|
|
|
pack .extract_frame .aux_control_frame .insert_frame \
|
|
-in .localfs -side top -expand 1 -fill both
|
|
}
|
|
|
|
|
|
# The means for extracting files from ISO image to disk
|
|
#
|
|
proc init_extract {} {
|
|
global borderwidth extract_to_adr extract_from_selected extract_underneath
|
|
global .extract_button .extract_frame .extract_entry .extract_from_selected
|
|
global .extract_underneath
|
|
|
|
frame .extract_frame -borderwidth 0
|
|
button .extract_button -text "Extract to disk:" \
|
|
-width 17 \
|
|
-command {extract_to}
|
|
bind_help .extract_button "Extract to disk:"
|
|
entry .extract_entry -width 40 -relief sunken -bd 1 \
|
|
-textvariable "extract_to_adr"
|
|
bind_entry_keys .extract_entry {extract_to}
|
|
bind_help .extract_entry "Extract to disk:"
|
|
create_browser_button .extract_browse_button \
|
|
"extract_to_adr" "localfs" "Browse disk (extract)"
|
|
checkbutton .extract_underneath -text "Underneath" \
|
|
-indicatoron 1 -selectcolor "" \
|
|
-relief ridge -borderwidth 2 \
|
|
-variable extract_underneath \
|
|
-onvalue 1 -offvalue 0
|
|
bind_help .extract_underneath "Underneath (extract)"
|
|
checkbutton .extract_from_selected -text "Selected" \
|
|
-indicatoron 1 -selectcolor "" \
|
|
-relief ridge -borderwidth 2 \
|
|
-variable extract_from_selected \
|
|
-onvalue 1 -offvalue 0
|
|
bind_help .extract_from_selected "Selected (extract)"
|
|
pack .extract_button -in .extract_frame -side left
|
|
pack .extract_entry \
|
|
-in .extract_frame -side left -expand 1 -fill both
|
|
pack .extract_from_selected .extract_underneath \
|
|
-in .extract_frame -side right
|
|
pack .extract_browse_button -in .extract_frame -side right
|
|
}
|
|
|
|
|
|
# Some controls which apply to insertion, extraction, or both.
|
|
#
|
|
proc init_aux_control {} {
|
|
global borderwidth have_bwidget permission_policy
|
|
global .aux_control_frame
|
|
global .overwrite_iso_files_button .overwrite_dir_button .extract_auto_chmod
|
|
|
|
frame .aux_control_frame -borderwidth 0
|
|
|
|
menubutton .overwriting -text "Overwriting:" -width 16 -anchor w \
|
|
-direction above -relief ridge -indicatoron 1 \
|
|
-menu .overwriting.menu
|
|
bind_help .overwriting "Overwriting:"
|
|
set_overwriting_label
|
|
set m ".overwriting.menu"
|
|
menu $m
|
|
$m add checkbutton -label "Overwrite ISO files" \
|
|
-indicatoron 1 -selectcolor "" \
|
|
-command set_overwriting_label \
|
|
-variable overwrite_iso_files \
|
|
-onvalue 1 -offvalue 0
|
|
$m add checkbutton -label "Overwrite ISO dirs" \
|
|
-indicatoron 1 -selectcolor "" \
|
|
-command set_overwriting_label \
|
|
-variable overwrite_iso_dirs \
|
|
-onvalue 1 -offvalue 0
|
|
$m add checkbutton -label "Overwrite hard disk files" \
|
|
-indicatoron 1 -selectcolor "" \
|
|
-command set_overwriting_label \
|
|
-variable overwrite_disk_files \
|
|
-onvalue 1 -offvalue 0
|
|
$m add checkbutton -label "Enforce disk dir write access" \
|
|
-indicatoron 1 -selectcolor "" \
|
|
-command set_overwriting_label \
|
|
-variable extract_auto_chmod \
|
|
-onvalue 1 -offvalue 0
|
|
|
|
pack .overwriting -in .aux_control_frame -side left
|
|
|
|
if {$have_bwidget == 1} {
|
|
checkbutton .browse_select_is_setvar -text "File browser text field" \
|
|
-indicatoron 1 -selectcolor "" \
|
|
-relief ridge -borderwidth 2 \
|
|
-variable "browse_select_is_setvar" \
|
|
-onvalue 1 -offvalue 0
|
|
bind_help .browse_select_is_setvar "File browser text field"
|
|
pack .browse_select_is_setvar -in .aux_control_frame -side left
|
|
}
|
|
|
|
menubutton .perm_policy -text "Permissions: as is" -width 22 -anchor w \
|
|
-direction above -relief ridge -indicatoron 1 \
|
|
-menu .perm_policy.menu
|
|
set m ".perm_policy.menu"
|
|
menu $m -tearoff 0
|
|
$m add radiobutton -label "as is" -value "as_is" \
|
|
-variable permission_policy -command show_permission_policy
|
|
$m add radiobutton -label "readable" -value "readable" \
|
|
-variable permission_policy -command show_permission_policy
|
|
$m add radiobutton -label "readonly" -value "readonly" \
|
|
-variable permission_policy -command show_permission_policy
|
|
$m add radiobutton -label "mkisofs -r" -value "mkisofs_r" \
|
|
-variable permission_policy -command show_permission_policy
|
|
show_permission_policy
|
|
bind_help .perm_policy "Permissions:"
|
|
|
|
button .avail_button -text "Refresh avail:" \
|
|
-command {refresh_avail}
|
|
bind_help .avail_button "Refresh avail:"
|
|
frame .avail_label_frame -relief ridge -borderwidth 2
|
|
label .avail_label -width 10 -text ""
|
|
bind_help .avail_label "Refresh avail:"
|
|
pack .avail_label -in .avail_label_frame
|
|
|
|
pack .avail_label_frame .avail_button .perm_policy \
|
|
-in .aux_control_frame -side right
|
|
}
|
|
|
|
|
|
# The means for inserting files from disk into the ISO image
|
|
#
|
|
proc init_insert {} {
|
|
global borderwidth insert_from_adr insert_at_selected insert_underneath
|
|
global .insert_button .insert_from_frame .insert_entry .insert_at_selected
|
|
global .insert_underneath .insert_frame
|
|
|
|
frame .insert_frame -borderwidth 0
|
|
frame .insert_from_frame -borderwidth 0
|
|
button .insert_button -text "Insert from disk:" \
|
|
-width 17 \
|
|
-command {insert_from}
|
|
bind_help .insert_button "Insert from disk:"
|
|
entry .insert_entry -width 40 -relief sunken -bd 1 \
|
|
-textvariable "insert_from_adr"
|
|
bind_entry_keys .insert_entry {insert_from}
|
|
bind_help .insert_entry "Insert from disk:"
|
|
create_browser_button .insert_browse_button \
|
|
"insert_from_adr" "localfs" "Browse disk (insert)"
|
|
checkbutton .insert_underneath -text "Underneath" \
|
|
-indicatoron 1 -selectcolor "" \
|
|
-relief ridge -borderwidth 2 \
|
|
-variable insert_underneath \
|
|
-onvalue 1 -offvalue 0
|
|
bind_help .insert_underneath "Underneath (insert)"
|
|
checkbutton .insert_at_selected -text "Selected" \
|
|
-indicatoron 1 -selectcolor "" \
|
|
-relief ridge -borderwidth 2 \
|
|
-variable insert_at_selected \
|
|
-onvalue 1 -offvalue 0
|
|
bind_help .insert_at_selected "Selected (insert)"
|
|
pack .insert_button -in .insert_from_frame -side left
|
|
pack .insert_entry \
|
|
-in .insert_from_frame -side left -expand 1 -fill both
|
|
pack .insert_browse_button -in .insert_from_frame -side left
|
|
pack .insert_at_selected .insert_underneath \
|
|
-in .insert_from_frame -side right
|
|
pack .insert_from_frame -in .insert_frame -side left -expand 1 -fill both
|
|
}
|
|
|
|
|
|
# Set common behavior of listboxes in respect to focus and navigation keys.
|
|
#
|
|
proc bind_listbox_keys {box height what_widget} {
|
|
global click_to_focus
|
|
|
|
if {$click_to_focus == 1} {
|
|
bind $box <1> "focus \"$box\""
|
|
bind $box <2> "focus \"$box\""
|
|
bind $box <3> "focus \"$box\""
|
|
} else {
|
|
bind $box <Enter> "focus \"$box\""
|
|
}
|
|
|
|
# No underlining
|
|
if {$what_widget == "listbox"} {
|
|
$box configure -activestyle "none"
|
|
}
|
|
|
|
# Need to evaluate all $box and $height at bind-time. Thus "-quotes.
|
|
bind $box <Any-KeyPress> "
|
|
if {\"%K\" == \"Up\"} {
|
|
$box yview scroll \"-1\" units
|
|
}
|
|
if {\"%K\" == \"Down\"} {
|
|
$box yview scroll 1 units
|
|
}
|
|
if {\"%K\" == \"Prior\"} {
|
|
$box yview scroll -[expr \"$height\" - 1] units
|
|
# $box yview scroll -1 pages
|
|
}
|
|
if {\"%K\" == \"Next\"} {
|
|
$box yview scroll [expr \"$height\" - 1] units
|
|
# $box yview scroll 1 pages
|
|
}
|
|
if {\"%K\" == \"Home\"} {
|
|
$box yview 0
|
|
}
|
|
if {\"%K\" == \"End\"} {
|
|
$box yview end
|
|
}
|
|
|
|
# >>> Do i need this ?
|
|
# >>> For now: yes. It prevents double scrolling by PgUp PgDown
|
|
# Prevent other bindings from being performed
|
|
break
|
|
"
|
|
}
|
|
|
|
|
|
# Set common behavior of entries in respect to focus and Return key.
|
|
#
|
|
proc bind_entry_keys {entry return_cmd} {
|
|
global click_to_focus
|
|
|
|
if {$click_to_focus != 1} {
|
|
bind $entry <Enter> "focus \"$entry\""
|
|
}
|
|
if {$return_cmd != ""} {
|
|
bind $entry <Return> $return_cmd
|
|
}
|
|
}
|
|
|
|
|
|
# Bind a help text to a widget.
|
|
#
|
|
proc bind_help {to_what help_name} {
|
|
bind $to_what <Button-3> "window_help \"$help_name\" grey"
|
|
}
|
|
|
|
|
|
# Create a "/" button and wire it with variable, fileystem type, and help text.
|
|
#
|
|
proc create_browser_button {button_name var_name which_fs help_name} {
|
|
global have_bwidget
|
|
|
|
button $button_name -text "/" -command "browse_tree $var_name $which_fs"
|
|
bind_help $button_name $help_name
|
|
}
|
|
|
|
|
|
proc set_overwriting_label {} {
|
|
global overwrite_iso_files overwrite_iso_dirs overwrite_disk_files
|
|
global extract_auto_chmod
|
|
global .overwriting
|
|
|
|
# Determine text suffix for menubutton from overwrite variables
|
|
set oif "-"
|
|
if {$overwrite_iso_files == 1} {set oif "f"}
|
|
set oid "-"
|
|
if {$overwrite_iso_dirs == 1} {set oid "d"}
|
|
set ohf "-"
|
|
if {$overwrite_disk_files == 1} {set ohf "h"}
|
|
set fdw "-"
|
|
if {$extract_auto_chmod == 1} {set fdw "w"}
|
|
set otext "Overwriting: ${oif}${oid}${ohf}${fdw}"
|
|
.overwriting configure -text $otext
|
|
}
|
|
|
|
|
|
# The central storage for help texts.
|
|
#
|
|
proc tell_helptext {what} {
|
|
global own_version argv0 bwidget_version
|
|
|
|
if {$what == "Help"} {
|
|
return \
|
|
"For getting particular help texts:
|
|
|
|
Click the rightmost mouse button on any button, list box, or text field.
|
|
|
|
For a help text about startup options of this frontend, execute in a shell:
|
|
|
|
$argv0 --help
|
|
|
|
For background info about xorriso and its commands, execute in a shell:
|
|
|
|
man xorriso
|
|
|
|
-----------------------------------------------------------------------------
|
|
|
|
The GUI window is separated into three main areas:
|
|
|
|
- The area for connection to xorriso
|
|
- shows xorriso messages,
|
|
- offers some general activities,
|
|
- displays the \"ready/busy\" state of the connection,
|
|
- and allows to toggle xorriso commands into the \"Command:\" field.
|
|
|
|
- The area for management of drives and ISO image data files
|
|
- allows to scan for optical drives,
|
|
- to aquire them and load their ISO directory tree,
|
|
- to aquire ISO image files from hard disk as pseudo drives like DVD+RW,
|
|
- to blank CD-RW, DVD=RW, DVD+RW, BD-RE and format DVD-RW, BD-R,
|
|
- to trigger writing of ISO sessions (which get defined in the third area),
|
|
- and to burn image data files from hard disk to optical media.
|
|
|
|
- The area for inspection, manipulation, and exploitation of the ISO model
|
|
- allows to insert directories and files from hard disk into the ISO model,
|
|
- to delete and rename file objects in the ISO model,
|
|
- to verify data files of loaded ISO directory trees by MD5,
|
|
- to extract directories and files from ISO filesystem to hard disk.
|
|
|
|
-----------------------------------------------------------------------------
|
|
Some Use Cases
|
|
-----------------------------------------------------------------------------
|
|
|
|
- Burn a directory as only content onto a CD, DVD or BD
|
|
- Write a directory as only content to an ISO image data file on hard disk
|
|
- Burn an image data file from hard disk onto CD, DVD or BD
|
|
- Add more data to an appendable medium or to an ISO image data file
|
|
- Extract a directory tree from an ISO filesystem to hard disk
|
|
|
|
-----------------------------------------------------------------------------
|
|
|
|
Burn a directory as only content onto a CD, DVD or BD
|
|
|
|
- Click the \"Scan for drives\" button in the middle area.
|
|
- Select a drive and click the \"Pick output drive\" button.
|
|
- If the information field in the \"Output drive/image\" line begins by
|
|
\"appendable\" or \"closed\" and if the medium is CD-RW, DVD-RW, DVD+RW, or
|
|
BD-RE then click the \"Blank\" button to erase the old data.
|
|
(Blanking of \"DVD-RW sequential recording\" will last very long.)
|
|
- Go to the \"Insert from disk:\" line in the lower area.
|
|
Either toggle in the address of the hard disk directory,
|
|
or click on the \"/\" button to the right of the text field to get
|
|
a file browser.
|
|
- Hit the Return key in the text field or double click on a name in the
|
|
browser to schedule the disk directory for writing to the medium.
|
|
(You may of course insert several directories or files that way.)
|
|
- Click the \"Write ISO session\" button in the middle area.
|
|
Confirm in the \"yes/no\" window that pops up.
|
|
Burning will begin (or refuse on unsuitable medium status).
|
|
- When the \"busy\" field displays \"ready\" again, you may click \"Eject\".
|
|
Desktop drives should then put out the tray with the medium.
|
|
|
|
-----------------------------------------------------------------------------
|
|
|
|
Write a directory as only content to an ISO image data file on hard disk
|
|
|
|
- Go to the text field beneath \"Output drive/image\" and toggle
|
|
the address of the image file. Or click on the \"/\" button to the right
|
|
of the field to get a file browser.
|
|
- You may click on a name in the browser and bring it into the text field
|
|
by button \"Edit\".
|
|
- When the intended file address is composed, hit the Return key in the
|
|
text field.
|
|
- If the information field in the \"Output drive/image\" line begins by
|
|
\"appendable\" or \"closed\" then you addressed an existing data file.
|
|
Warning: Applying the \"Blank\" button to it would damage its content !
|
|
You probably do not want this in this special use case.
|
|
- Go to the \"Insert from disk:\" line in the lower area.
|
|
Continue like in the above description for CD, DVD, and BD media.
|
|
|
|
-----------------------------------------------------------------------------
|
|
|
|
Burn an image data file from hard disk onto CD, DVD or BD
|
|
|
|
- Click the \"Scan for drives\" button in the middle area.
|
|
- Select a drive and click the \"Pick output drive\" button.
|
|
- If the information field in the \"Output drive/image\" line begins by
|
|
\"appendable\" or \"closed\" and if the medium is CD-RW, DVD-RW, DVD+RW, or
|
|
BD-RE then click the \"Blank\" button to erase the old data.
|
|
(Blanking of \"DVD-RW sequential recording\" will last very long.)
|
|
- Go to the text field beneath the \"Burn image file:\" button and toggle
|
|
the address of the image file. Or click on the \"/\" button to the right
|
|
of the field to get a file browser.
|
|
- Hit the Return key in the text field or double click on a name in the
|
|
browser to initiate the burn run.
|
|
Confirm in the \"yes/no\" window that pops up.
|
|
- When the \"busy\" field displays \"ready\" again, you may click \"Eject\".
|
|
Desktop drives should then put out the tray with the medium.
|
|
|
|
-----------------------------------------------------------------------------
|
|
|
|
Add more data to an appendable medium or to an ISO image data file
|
|
|
|
- Like above, \"Scan for drives\" but click button \"Pick drive for both roles\"
|
|
in order to load the directory tree of the existing ISO filesystem.
|
|
For an ISO image data file, bring its name into the input fields of both
|
|
lines \"Input drive/image\" and \"Output drive/image\".
|
|
You should now see in both info fields texts which begin by \"appendable\".
|
|
- Go to the \"Insert from disk:\" line in the lower area.
|
|
Use the means described in the first use case to add more directories or
|
|
data files.
|
|
- If you are interested in \"Delete\" or \"Move to:\" buttons in the
|
|
bottom line of the GUI: Click them by the rightmost mouse button to see
|
|
their help texts.
|
|
- When all intended changes are done: Click \"Write ISO session\" and
|
|
confirm in the \"yes/no\" window.
|
|
|
|
-----------------------------------------------------------------------------
|
|
|
|
Extract a directory tree from an ISO filesystem to hard disk
|
|
|
|
- Like above, \"Scan for drives\" but click button \"Pick input drive\"
|
|
in order to load the directory tree of the existing ISO filesystem.
|
|
For an ISO image data file, bring its name into the input field of the
|
|
lines \"Input drive/image\" and \"Output drive/image\".
|
|
You should now see in both info fields texts which begin by \"appendable\".
|
|
- Go to the \"ISO directory:\" line in the lower area.
|
|
Either toggle in the address of the directory you want to extract or
|
|
click the \"/\" button to get a file browser.
|
|
- Hit the Return key in the text field or double click on a name in the
|
|
browser to determine the ISO directory for writing to the medium.
|
|
- Go to the \"Extract to disk:\" line in the lower area.
|
|
Either toggle in the address of the hard disk directory,
|
|
or click on the \"/\" button to the right of the text field to get
|
|
a file browser.
|
|
- Hit the Return key in the text field or double click on a name in the
|
|
browser to initiate the extraction run.
|
|
If a \"yes/no\" window pops up, consider well whether you are up to
|
|
to shooting your own foot right now.
|
|
Enable the \"Overwrite hard disk files\" switch only if you are really
|
|
sure that the files from ISO are better than the ones on hard disk.
|
|
|
|
-----------------------------------------------------------------------------
|
|
|
|
xorriso-tcltk is mainly a proof of concept for a frontend that operates
|
|
xorriso in dialog mode.
|
|
|
|
It demonstrates some of xorriso's multi-session features with ISO 9660
|
|
filesystems on optical media (CD, DVD, BD) or in disk files.
|
|
|
|
Dependencies:
|
|
xorriso, Tcl language, Tk GUI toolkit, optionally Tcl/Tk package BWidget
|
|
|
|
Copyright (C) 2012 - 2013
|
|
Thomas Schmitt <scdbackup@gmx.net>, libburnia-project.org
|
|
Provided under BSD license: Use, modify, and distribute as you like."
|
|
}
|
|
if {$what == "End"} {
|
|
return \
|
|
"The \"End\" button leads to the end of frontend and xorriso process."
|
|
}
|
|
if {$what == "version"} {
|
|
return \
|
|
"The field between \"End\" button and ready/busy field displays the
|
|
version of the serving xorriso program.
|
|
|
|
xorriso is a program which copies file objects from POSIX compliant
|
|
filesystems into Rock Ridge enhanced ISO 9660 filesystems and allows
|
|
session-wise manipulation of such filesystems. It can load the management
|
|
information of existing ISO images and it writes the session results to
|
|
optical media or to filesystem objects.
|
|
Vice versa xorriso is able to restore file objects from ISO 9660 filesystems.
|
|
|
|
xorriso-tcltk-$own_version is mainly a proof of concept for a frontend
|
|
that operates xorriso in dialog mode.
|
|
|
|
It exercises several fundamental gestures of communication:
|
|
- connecting via two pipes
|
|
- sending commands
|
|
- receiving replies
|
|
- inquiring the xorriso message sieve
|
|
- using the xorriso parsing service
|
|
|
|
Note that any other language than Tcl/Tk could be used, if it only can
|
|
do i/o via standard input and standard output or via named pipes.
|
|
Further it has to perform integer arithmetics and string manipulations.
|
|
And, well, a graphical widget set would be nice."
|
|
}
|
|
if {$what == "Refresh disp"} {
|
|
return \
|
|
"The \"Refresh disp\" button causes several text fields and list
|
|
boxes to update their display after manually transmitted commands may
|
|
have changed the state of drives or ISO model."
|
|
}
|
|
if {$what == "ready/busy"} {
|
|
return \
|
|
"The ready/busy field indicates whether a xorriso command is being executed
|
|
and the frontend is still waiting for its reply messages."
|
|
}
|
|
if {$what == "Command:"} {
|
|
return \
|
|
"The \"Command:\" field can be used to send commands to xorriso.
|
|
See the manual page of xorriso for its concepts and commands."
|
|
}
|
|
if {$what == "Script/Log"} {
|
|
return \
|
|
"The \"Script/Log\" menu controls logging of xorriso commands and replies.
|
|
|
|
The \"Log command script\" switch controls whether the essential xorriso
|
|
commands of the GUI session shall be written to the end of a script file
|
|
on hard disk. Not written will be the commands by which the GUI inspects
|
|
the xorriso state, but only those which set up that state and those which
|
|
get sent via the \"Command:\" field.
|
|
Commands -osirrox and -extract will be logged only as comments.
|
|
|
|
The item \"Set log script address\" pops up a file tree browser window
|
|
which asks for the target of appending to script. Address \"-\" means
|
|
standard error. Else it must not yet exist or be a writable data file.
|
|
|
|
The \"Log pipes\" switch controls whether all xorriso commands and replies
|
|
shall be logged to standard error resp. to the file that has been given
|
|
with program argument --pipe_log_file.
|
|
Caution: This log is verbous.
|
|
|
|
The item \"Set pipe log address\" pops up a file tree browser window
|
|
which asks for the target of pipe logging . Address \"-\" means
|
|
standard error. Else it must not yet exist or be a writable data file.
|
|
|
|
The item \"Execute command script\" executes the commands in a script
|
|
file that should stem from \"Log command script\".
|
|
At least it must begin by this line:
|
|
# xorriso-tcltk command log script
|
|
Be aware that xorriso will slavishly execute those commands. Better check
|
|
in advance whether the content of the script file is what you expect.
|
|
See man xorriso for the meaning of the commands.
|
|
|
|
The \"Allow extract to disk\" switch controls whether commands like -extract
|
|
are allowed in command scripts. If disabled, then command -osirrox is used
|
|
to temporarily block those commands (unless the script ublocks itself, which
|
|
would be nasty behavior).
|
|
|
|
The item \"Permanently ban extraction\" disables -extract irrevocably for
|
|
scripts and GUI alike."
|
|
}
|
|
if {$what == "message box"} {
|
|
return \
|
|
"The message box displays commands sent to xorriso and messages received
|
|
from xorriso.
|
|
|
|
Many commands which are emitted by the GUI will hide themselves and their
|
|
replies from this display. All event messages with severity WARNING or
|
|
higher will show up, nevertheless."
|
|
}
|
|
if {$what == "Recent problem:"} {
|
|
return \
|
|
"The \"Recent problem:\" field shows the most severe event message that occured
|
|
during the execution of the most recent command. It also displays the most
|
|
recent problem message from the frontend program itself.
|
|
|
|
Several commands emitted by the GUI will not clear this display. But any
|
|
manually transmitted command and the major GUI gestures will do.
|
|
"
|
|
}
|
|
if {$what == "Worst problem:"} {
|
|
return \
|
|
"The \"Worst problem:\" field shows the most severe event message that occured
|
|
since last time the \"Clear\" button was hit. It will not clear automatically."
|
|
}
|
|
if {$what == "Clear"} {
|
|
return \
|
|
"The \"Clear\" button removes the message from the \"Worst problem:\" field."
|
|
}
|
|
if {$what == "Scan for drives"} {
|
|
return \
|
|
"The \"Scan for drives\" button executes command -devices and puts the list
|
|
of found optical drives into the box beneath the button.
|
|
|
|
Scanning should be done before any ISO image manipulations because xorriso
|
|
has to give up its aquired drives in order to perform the scan run.
|
|
|
|
To become visible and to be usable, the drives have to offer rw-permission
|
|
to the user of this program. If drives do not show up, then consider to
|
|
become superuser and to execute
|
|
xorriso -devices
|
|
Then apply
|
|
chmod a+rw
|
|
to the listed device files. (Consider to use finer means of permission
|
|
granting for a permanent solution.)"
|
|
}
|
|
if {$what == "Pick input drive"} {
|
|
return \
|
|
"The \"Pick input drive\" button executes command -indev and obtains some
|
|
information about the medium status. This info is displayed in the
|
|
\"Input drive/image\" line.
|
|
Further it causes the display of the ISO image model to be updated.
|
|
|
|
The medium in the input drive must be blank or contain a valid ISO 9660
|
|
filesystem.
|
|
Choosing an input drive causes a root directory to be created in the ISO
|
|
model of xorriso. If there is a valid ISO filesystem in the input drive
|
|
then its directory tree gets loaded underneath that model root directory.
|
|
|
|
The input drive may also be a data file on hard disk if that file contains
|
|
an ISO 9660 filesystem image. See field \"Input drive/image\"."
|
|
}
|
|
if {$what == "Pick output drive"} {
|
|
return \
|
|
"The \"Pick output drive\" button executes command -outdev and obtains some
|
|
information about the medium status. This info is displayed in the
|
|
\"Output drive/image\" line.
|
|
|
|
The output drive may be empty or loaded with a medium, that may be blank,
|
|
appendable or closed.
|
|
It is usable for writing only if there is a medium inserted which is either
|
|
blank or appendable. Button \"Blank\" can bring appendable or closed media
|
|
into blank state.
|
|
|
|
The output drive may also be a data file on hard disk. See field
|
|
\"Output drive/image\"."
|
|
It is considered appendable if it contains an ISO 9660 filesystem image.
|
|
It is considered blank if it is empty or marked as blank by button \"Blank\".
|
|
It is considered closed if it contains other data."
|
|
}
|
|
if {$what == "Pick drive for both roles"} {
|
|
return \
|
|
"The \"Pick drive for both roles\" button executes command -dev and obtains some
|
|
information about the medium status. This info is displayed in the
|
|
\"Input drive/image\" line and in the \"Output drive/image\" line.
|
|
Further it causes the display of the ISO image model to be updated.
|
|
|
|
The medium in the drive must be blank or contain a valid ISO 9660 filesystem.
|
|
Else the drive will only be aquired as output drive.
|
|
|
|
This drive configuration is the most usual one with xorriso. It loads
|
|
an eventual ISO image, allows to manipulate it by insertion, deletion,
|
|
and renaming. When this is done, the changes get written to the drive
|
|
via button \"Write ISO session\".
|
|
|
|
The drive may also be a data file on hard disk.
|
|
See fields \"Input drive/image\" and \"Output drive/image\".
|
|
It is considered appendable if it contains an ISO 9660 filesystem image.
|
|
It is considered blank if it is empty or marked as blank by button \"Blank\".
|
|
It is considered closed if it contains other data."
|
|
}
|
|
if {$what == "Give up drives"} {
|
|
return \
|
|
"The \"Give up drives\" button executes commands -indev \"\" -outdev \"\"
|
|
and clears both \"... drive/image\" lines, as well as the ISO model."
|
|
}
|
|
if {$what == "Calm drives"} {
|
|
return \
|
|
"The \"Calm drives\" button executes command -calm_drives which tells the
|
|
aquired optical drives to stop spinning until the next drive activity
|
|
gets triggered."
|
|
}
|
|
if {$what == "Rollback"} {
|
|
return \
|
|
"The \"Rollback\" button executes command -rollback which drops all pending
|
|
changes of the ISO model and reloads it from the input drive, if one is
|
|
aquired."
|
|
}
|
|
if {$what == "drivelist"} {
|
|
return \
|
|
"The box beneath the \"Scan for drives\" button shows the optical drives
|
|
which were found by the most recent scan run.
|
|
|
|
A double-click on a drive item has the same effect as button
|
|
\"Pick drive for both roles\".
|
|
"
|
|
}
|
|
if {$what == "Input drive/image"} {
|
|
return \
|
|
"The \"Input drive/image\" field displays the address of the input drive.
|
|
Editing the drive address and pressing the Return key causes the execution
|
|
of command -indev with the field content as drive address.
|
|
|
|
Use this to load the model from an ISO image data file on hard disk.
|
|
It is of course permissible that input image and output image are the
|
|
same file.
|
|
"
|
|
}
|
|
if {$what == "input drive info"} {
|
|
return \
|
|
"The text field beneath the \"Input drive/image\" field displays the medium
|
|
status of the input drive. It tells about the writability, the medium type,
|
|
the number of ISO sessions, and the amount of readable data."
|
|
}
|
|
if {$what == "Eject (indev)"} {
|
|
return \
|
|
"The \"Eject\" button beneath the \"Input drive/image\" field excutes
|
|
command -eject \"in\"."
|
|
}
|
|
if {$what == "Output drive/image"} {
|
|
return \
|
|
"The \"Output drive/image\" field displays the address of the output drive.
|
|
Editing the drive address and pressing the Return key causes the execution
|
|
of command -outdev with the field content as drive address.
|
|
|
|
Use this to direct writing to an ISO image data file on hard disk.
|
|
It is of course permissible that input image and output image are the
|
|
same file.
|
|
"
|
|
}
|
|
if {$what == "output drive info"} {
|
|
return \
|
|
"The text beneath the \"Output drive/image\" field displays the medium
|
|
status of the output drive. It tells about the writability, the medium type,
|
|
the number of ISO sessions, and the amount of free space."
|
|
}
|
|
if {$what == "Eject (outdev)"} {
|
|
return \
|
|
"The \"Eject\" button beneath the \"Output drive/image\" field excutes
|
|
command -eject \"out\"."
|
|
}
|
|
if {$what == "Blank"} {
|
|
return \
|
|
"The \"Blank\" button executes command -blank \"as_needed\" on the output drive
|
|
in order to make a re-usable medium or an ISO image data file writable from
|
|
scratch.
|
|
|
|
Genuine blanking applies only to CD-RW and DVD-RW.
|
|
But xorriso emulates ISO 9660 multi-session on DVD+RW, DVD-RAM,
|
|
formatted DVD-RW, BD-RE, as well as in ISO image data files on hard disk.
|
|
On those media and pseudo media, blanking will be performed by a small
|
|
write operation which invalidates their existing ISO filesystem.
|
|
|
|
One-time writable media CD-R, DVD-R, DVD+R, and BD-R cannot be blanked."
|
|
}
|
|
if {$what == "Format"} {
|
|
return \
|
|
"The \"Format\" button executes -format \"as_needed\".
|
|
|
|
This only applies to real optical drives and is of interest only with DVD-RW
|
|
or BD-R media, which both can be used formatted and unformatted. Other media
|
|
types which mandatorily need formatting will be formatted by the write
|
|
commands.
|
|
|
|
Formatted DVD-RW media have the advantage of being overwritable and thus
|
|
being quickly blankable while maintaining the capability for multi-session.
|
|
|
|
Formatted BD-R can perform Defect Management, which is of questionable value."
|
|
}
|
|
if {$what == "Write ISO session"} {
|
|
return \
|
|
"The \"Write ISO session\" executes command -commit, which writes a session
|
|
with all pending changes to the output drive.
|
|
|
|
The output drive must be either blank or it must be the same as the input
|
|
drive.
|
|
|
|
Writing the session is the last step in the course of creating a new ISO
|
|
filesystem or an add-on session that expands or changes the ISO filesystem
|
|
on the medium of the output drive.
|
|
So first choose a drive, then insert files from hard disk or do other
|
|
manipulations, and then click \"Write ISO session\" to let xorriso
|
|
write the data to medium or ISO image file.
|
|
"
|
|
}
|
|
if {$what == "Close"} {
|
|
return \
|
|
"The \"Close\" switch controls whether command -close \"on\" is emitted with
|
|
\"Write ISO session\" or whether -as cdrecord option -multi is omitted with
|
|
\"Burn image file:\".
|
|
|
|
Closed optical media cannot be written any more unless they get blanked,
|
|
which is not possible with CD-R, DVD-R, DVD+R, and BD-R.
|
|
"
|
|
}
|
|
if {$what == "TAO"} {
|
|
return \
|
|
"The \"TAO\" switch controls whether an incremental MMC write type shall be
|
|
enforced with write commands. See xorriso command -write_type.
|
|
|
|
Normally xorriso will decide by medium status and job parameters which
|
|
MMC write type to choose. Some drives at the edge of failure might work
|
|
with the one write type while already failing with the other."
|
|
}
|
|
if {$what == "Defect Mgt"} {
|
|
return \
|
|
"The \"Defect Mgt\" switch controls whether slow and error-prone drive internal
|
|
check-reading shall be enabled when writing to formatted BD-R or BD-RE.
|
|
See xorriso command -stream_recording."
|
|
}
|
|
if {$what == "Burn image file:"} {
|
|
return \
|
|
"The \"Burn image file:\" button executes command -as \"cdrecord\" to
|
|
burn a data file from hard disk onto the output drive.
|
|
The address of the disk file is taken from the neighboring text field.
|
|
|
|
The medium in the drive must be blank.
|
|
|
|
(It is well possible to burn image files to appendable media. But the
|
|
image needs to be prepared for the address offset. Who can do that can
|
|
as well use one of the command line tools for burning the result. E.g.
|
|
xorriso -as cdrecord -v dev=/dev/sr0 -multi stream_recording=32s image.iso
|
|
)"
|
|
}
|
|
if {$what == "Extract to disk:"} {
|
|
return \
|
|
"The \"Extract to disk:\" button executes command -extract with the whole
|
|
tree of the current ISO directory or with the selected items of the box
|
|
underneath \"ISO directory:\".
|
|
|
|
This copies the selected files or directory trees from the input drive
|
|
to the address on hard disk which is given by the text field right of
|
|
the button."
|
|
}
|
|
if {$what == "Browse tree"} {
|
|
return "[tell_file_browser_help 0]"
|
|
}
|
|
if {$what == "Close (browse tree)"} {
|
|
return \
|
|
"The \"Close\" button in the file browser closes the browser window without
|
|
performing other actions."
|
|
}
|
|
if {$what == "Up (browse tree)"} {
|
|
return \
|
|
"The \"Up\" button in the file browser brings you to the parent directory
|
|
of the currently selected file tree item.
|
|
|
|
The parent directory will be opened and become the selected item.
|
|
All opened directory trees underneath the parent will be closed."
|
|
}
|
|
if {$what == "Down (browse tree)"} {
|
|
return \
|
|
"The \"Down\" button in the file browser opens the directory underneath
|
|
the currently selected file tree item.
|
|
|
|
It has the same effect as clicking the \"+\" node of the selected item."
|
|
}
|
|
if {$what == "Accept (browse tree)"} {
|
|
return \
|
|
"The \"Accept\" button in the file browser brings the single selected item
|
|
from the file browser tree into effect with the associated text field.
|
|
I.e. it hits the Return key of the field.
|
|
|
|
It works as if the item had been double clicked."
|
|
}
|
|
if {$what == "Edit (browse tree)"} {
|
|
return \
|
|
"The \"Edit\" button in the file browser brings the single selected item
|
|
from the file browser tree into the associated text field.
|
|
|
|
It does not hit the Return key of the field, but gives you the opportunity
|
|
to edit the file address.
|
|
|
|
(This is done automatically with every selection if the switch
|
|
\"File browser text field\" is enabled.)"
|
|
}
|
|
if {$what == "Browse disk (extract)"} {
|
|
return \
|
|
"The \"/\" button in the \"Extract to disk:\" line pops up a file tree
|
|
browser to select a target address in the hard disk filesystem.
|
|
|
|
[tell_file_browser_help 1]"
|
|
}
|
|
if {$what == "Browse disk (burn image)"} {
|
|
return \
|
|
"The \"/\" button beneath the \"Burn image file\" field pops up a file
|
|
tree browser to select a source address in the hard disk filesystem.
|
|
|
|
[tell_file_browser_help 1]"
|
|
}
|
|
if {$what == "Browse disk (insert)"} {
|
|
return \
|
|
"The \"/\" button beneath the \"Insert from disk\" field pops up a file
|
|
tree browser to select a source address in the hard disk filesystem.
|
|
|
|
[tell_file_browser_help 1]"
|
|
}
|
|
if {$what == "Browse disk (indev)"} {
|
|
return \
|
|
"The \"/\" button in the \"Input drive/image\" line pops up a file tree
|
|
browser to select a source address in the hard disk filesystem.
|
|
|
|
[tell_file_browser_help 1]"
|
|
}
|
|
if {$what == "Browse disk (outdev)"} {
|
|
return \
|
|
"The \"/\" button in the \"Output drive/image\" line pops up a file tree
|
|
browser to select a source address in the hard disk filesystem.
|
|
|
|
[tell_file_browser_help 1]"
|
|
}
|
|
if {$what == "Browse ISO (isodir)"} {
|
|
return \
|
|
"The \"/\" button in the \"ISO directory\" line pops up a file tree
|
|
browser to select the current directory in the ISO filesystem model.
|
|
|
|
[tell_file_browser_help 1]"
|
|
}
|
|
if {$what == "Browse ISO (move target)"} {
|
|
return \
|
|
"The \"/\" button in the \"Selection:\" line pops up a file tree
|
|
browser to select the current directory in the ISO filesystem model.
|
|
|
|
[tell_file_browser_help 1]"
|
|
}
|
|
if {$what == "Browse disk (dummy)"} {
|
|
return \
|
|
"Normally this button would start a file browser to select a file or
|
|
directory on hard disk.
|
|
|
|
But the browser cannot be displayed because Tcl/Tk package \"BWidget\"
|
|
is not loaded."
|
|
}
|
|
if {$what == "Browse ISO (dummy)"} {
|
|
return \
|
|
"Normally this button would start a file browser to select a file or
|
|
directory in the ISO model.
|
|
|
|
But the browser cannot be displayed because Tcl/Tk package \"BWidget\"
|
|
is not loaded."
|
|
}
|
|
if {$what == "Underneath (extract)"} {
|
|
return \
|
|
"The \"Underneath\" switch controls the effective hard disk target address
|
|
of an item if the address in the \"Extract to disk:\" field points to a
|
|
directory.
|
|
|
|
If \"Underneath\" is enabled, then the file object from the ISO filesystem
|
|
will be copied to its name underneath the hard disk directory.
|
|
If \"Underneath\" is disabled then an ISO directory tree item will be merged
|
|
with the disk directory tree at the given address.
|
|
|
|
Example:
|
|
Selected are \"/iso_dir\" and \"/iso_file\".
|
|
Address for hard disk is \"/tmp/from_iso\". Switch \"Selected\" is enabled.
|
|
\"Underneath\" enabled causes commands:
|
|
-extract /iso_dir /tmp/from_iso/iso_dir
|
|
-extract /iso_file /tmp/from_iso/iso_file
|
|
\"Underneath\" disabled:
|
|
-extract /iso_dir /tmp/from_iso
|
|
-extract /iso_file /tmp/from_iso
|
|
The last command will fail because /tmp/from_iso already exists as directory."
|
|
}
|
|
if {$what == "Selected (extract)"} {
|
|
return \
|
|
"The \"Selected\" switch controls whether the whole current ISO directory,
|
|
or only the selected items shall be copied to hard disk.
|
|
"
|
|
}
|
|
if {$what == "Overwriting:"} {
|
|
return \
|
|
"The \"Overwriting\" menu bundles several switches which control whether
|
|
existing files or directories may be overwritten.
|
|
|
|
The frontend program will only detect the most obvious name collisions,
|
|
but xorriso will reliably refuse to overwrite files if this is banned.
|
|
|
|
----------------------------------------------------------------------------
|
|
|
|
The \"Overwrite ISO files\" switch controls whether existing files may be
|
|
overwritten in the ISO image. See xorriso command -overwrite \"nondir\".
|
|
|
|
----------------------------------------------------------------------------
|
|
|
|
The \"Overwrite ISO dirs\" switch controls whether it is allowed to replace
|
|
an ISO directory by a non-directory file. See xorriso command -overwrite \"on\".
|
|
|
|
----------------------------------------------------------------------------
|
|
|
|
The \"Overwrite hard disk files\" switch controls whether existing files may be
|
|
overwritten by extraction to hard disk. See xorriso command -overwrite \"on\".
|
|
|
|
This is DANGEROUS, of course, but comes in handy with restoring of backups.
|
|
|
|
----------------------------------------------------------------------------
|
|
|
|
The \"Enforce disk dir write access\" switch enables the -osirrox options
|
|
\"auto_chmod_on\" and \"sort_lba_on\" which influence file extraction.
|
|
|
|
\"auto_chmod_on\" allows xorriso to give itself temporariy w-permission to
|
|
all disk directories which are owned by the xorriso user.
|
|
|
|
This is DANGEROUS, of course, but comes in handy with restoring of backups.
|
|
|
|
Option \"sort_lba_on\" reduces head-moves of optical drives and thus can
|
|
speed up extraction substantially. It is bound to \"auto_chmod_on\" because
|
|
else it might get into trouble when restoring ISO directories which offer
|
|
no w-permission."
|
|
}
|
|
if {$what == "File browser text field"} {
|
|
return \
|
|
"The \"File browser text field\" switch controls whether a single click
|
|
or cursor movement in the file browser shall bring the selected file
|
|
address into the associated text input field.
|
|
|
|
If the switch is disabled, then the address gets written into the field
|
|
only if double clicked, of by button \"Accept\", or by button \"Edit\".
|
|
|
|
In any case, double clicked addresses get treated as if the Return key
|
|
had been hit in the text field. The same happens with the selected item
|
|
and button \"Accept\"."
|
|
}
|
|
if {$what == "Permissions:"} {
|
|
return \
|
|
"The \"Permissions\" menu allows to choose a global policy to adjust
|
|
the access permissions of the files when an ISO session gets written.
|
|
|
|
The default policy \"as is\" leaves the permissions as they are.
|
|
Usually they have been imported from hard disk or from a loaded ISO image.
|
|
xorriso commands -chmod , -chmod_r, and -find ... -exec chmod --
|
|
may be used to perform permission manipulations.
|
|
|
|
Policy \"readable\" adds read permission to all kinds of files and
|
|
search permission to all directories.
|
|
|
|
Policy \"readonly\" sets the permissions of all kinds files to read-only.
|
|
Directories get added search permission.
|
|
|
|
Policy \"mkisofs -r\" does what option -r of program mkisofs does:
|
|
User id and group id become 0, all r-permissions get granted, all w denied.
|
|
If there is any x-permission, then all three x get granted. s- and t-bits
|
|
get removed.
|
|
"
|
|
}
|
|
if {$what == "Refresh avail:"} {
|
|
return \
|
|
"The \"Refresh avail:\" button triggers command -tell_media_space. It makes
|
|
a time consuming exact prediction of the free space on the medium in the
|
|
output drive. For this purpose, the size of an ISO session with the pending
|
|
changes is computed.
|
|
|
|
With image files rather than real optical drives, the free space of
|
|
the hosting filesystem is displayed."
|
|
}
|
|
if {$what == "Insert from disk:"} {
|
|
return \
|
|
"The \"Insert from disk:\" button executes command -map with the disk file
|
|
address that is given by the text field right to the button.
|
|
|
|
This inserts files or directory trees into the ISO image model and
|
|
schedules them for being copied with the next \"Write ISO session\" run.
|
|
|
|
The switches \"Underneath\" and \"Selected\" control what ISO address
|
|
the inserted files shall have. You may use buttons \"Delete\" and
|
|
\"Move to:\" for further adjustments.
|
|
"
|
|
}
|
|
if {$what == "Underneath (insert)"} {
|
|
return \
|
|
"The \"Underneath\" switch controls the effective ISO target address
|
|
if the address in the \"Insert from disk:\" field points to a hard disk
|
|
directory.
|
|
|
|
If \"Underneath\" is enabled, a directory from disk will not be unpacked
|
|
to its single files but be put underneath the target address by its own
|
|
leaf name."
|
|
|
|
If \"Underneath\" is disabled then the directory itself will not show up in
|
|
the ISO image but only its files and sub directories will do."
|
|
}
|
|
if {$what == "Selected (insert)"} {
|
|
return \
|
|
"If the switch \"Selected\" is enabled, then the given disk file or tree will
|
|
be inserted at or underneath the only selected item in the box underneath
|
|
\"ISO directory:\"."
|
|
}
|
|
if {$what == "ISO directory:"} {
|
|
return \
|
|
"The current ISO directory shall be used to navigate in the ISO image model
|
|
of xorriso. By default it is the target of file insertions and the source
|
|
of file extractions.
|
|
|
|
The text field in the \"ISO directory:\" line displays the current ISO
|
|
directory and can be used to toggle its path directly.
|
|
Hitting the Return key causes the current directory to change and the
|
|
display in the box underneath to be refreshed.
|
|
|
|
It is possible to choose the ISO directory by double-clicking an item
|
|
in the box underneath the \"ISO directory:\" line.
|
|
"
|
|
}
|
|
if {$what == "Up"} {
|
|
return \
|
|
"The \"Up\" buttons move the current ISO directory one directory level up."
|
|
}
|
|
if {$what == "Verify"} {
|
|
return \
|
|
"The \"Verify\" button executes -md5_check_r \"SORRY\" with the current ISO
|
|
directory.
|
|
|
|
This reads the content of all data files which are underneath the current ISO
|
|
directory and which have MD5 checksums in the ISO image.
|
|
ISO images bear MD5 checksums for each data file if they were produced
|
|
by xorriso with -md5 \"on\" resp. -for_backup. This frontend enables
|
|
this feature on startup."
|
|
}
|
|
if {$what == "isolist"} {
|
|
return \
|
|
"The list box underneath the \"ISO directory:\" line displays the files in
|
|
the current ISO directory. One or more item can be selected and play a
|
|
role with extraction or insertion of files.
|
|
|
|
Most of the buttons underneath the box operate on the selected items
|
|
unconditionally."
|
|
}
|
|
if {$what == "Selection:"} {
|
|
return \
|
|
"The ISO selection consists of the items which are selected in the list box
|
|
above the \"Selection:\" line.
|
|
|
|
If the respective \"Selected\" switches are enabled, then the ISO selection
|
|
is source of file extraction and target of file insertion.
|
|
|
|
In any case it is the old name of the \"Move to:\" button, the victim
|
|
of the \"Delete\" button, and the subject of the \"Verify\" button."
|
|
}
|
|
if {$what == "Verify (selection)"} {
|
|
return \
|
|
"The \"Verify\" button in the \"Selection:\" line executes command
|
|
-md5_check_r \"SORRY\" with each of the selected items.
|
|
|
|
This reads the content of all data files which are selected or underneath
|
|
selected directories and which have MD5 checksums in the ISO image.
|
|
ISO images bear MD5 checksums for each data file if they were produced
|
|
by xorriso with -md5 \"on\" resp. -for_backup. This frontend enables
|
|
this feature on startup."
|
|
}
|
|
if {$what == "Delete"} {
|
|
return \
|
|
"The \"Delete\" button executes command -rm_r with each of the selected items.
|
|
|
|
This removes the affected files and directory trees from the ISO model.
|
|
They will not show up in the directory tree of the next session that
|
|
is written via \"Write ISO session\". Nevertheless they will stay present
|
|
in earlier sessions if they were not freshly inserted after loading the
|
|
ISO model from the input drive.
|
|
"
|
|
}
|
|
if {$what == "Move to:"} {
|
|
return \
|
|
"The \"Move to:\" button uses command -mv to move each of the selected
|
|
items to the address that is given by the text field right to the button.
|
|
|
|
If this address points to an existing ISO directory, then the items will
|
|
be moved underneath that directory and keep their leaf names.
|
|
Else there may be only one selected item which will be renamed to the
|
|
given address."
|
|
}
|
|
if {$what == "Make dir"} {
|
|
return \
|
|
"The \"Make dir\" button executes command -mkdir with the address in the
|
|
text field to its left (the same as used by \"Move to:\").
|
|
|
|
Useful to create a target directory before moving the selection."
|
|
}
|
|
if {$what == "rename and mkdir target"} {
|
|
return \
|
|
"The text field between the \"Move to:\" button and the \"Make dir\" button
|
|
serves both buttons by providing the target address for renaming
|
|
resp. directory creation.
|
|
|
|
If you hit the Return key in this field, it will trigger \"Mode to:\"."
|
|
}
|
|
if {$what == "yes to all"} {
|
|
return \
|
|
"The \"yes to all\" button appears in the yes/no window if a GUI action is
|
|
about to overwrite a file object and more such overwrite situations are
|
|
to be expected.
|
|
|
|
If the button is clicked, then all further yes/no questions of that GUI
|
|
action will be answered automatically with yes.
|
|
|
|
[about_help_for_yesno]"
|
|
}
|
|
if {$what == "no to all"} {
|
|
return \
|
|
"The \"no to all\" button appears in the yes/no window if a GUI action is
|
|
about to overwrite a file object and more such overwrite situations are
|
|
to be expected.
|
|
|
|
If the button is clicked, then all further yes/no questions of that GUI
|
|
action will be answered automatically with no.
|
|
|
|
[about_help_for_yesno]"
|
|
}
|
|
if {$what == "Continue"} {
|
|
return \
|
|
"The \"Continue\" button appears in the notification windows which tell
|
|
about a failed or rejected GUI action.
|
|
|
|
---------------------------------------------------------------------------
|
|
|
|
It is impossible to trigger any further GUI action while the notification
|
|
window is displayed. You either have to click the \"Continue\" button
|
|
or hit the Return key.
|
|
|
|
You cannot even close this help window before you did that."
|
|
}
|
|
if {$what == "yes/no"} {
|
|
return \
|
|
"The \"yes\" and \"no\" buttons appear in the confirmation window which tells
|
|
about a potentially dangerous GUI action and demands a user decision whether
|
|
to really perform this action.
|
|
|
|
[about_help_for_yesno]"
|
|
}
|
|
|
|
return "--- No help text found for topic '$what'"
|
|
}
|
|
|
|
|
|
# Tell the general help text of the file browser.
|
|
#
|
|
proc tell_file_browser_help {with_separator} {
|
|
global have_bwidget
|
|
|
|
set text ""
|
|
if {$with_separator == 1} {
|
|
set text \
|
|
"-------------------------------------------------------------------------\n\n"
|
|
}
|
|
if {$have_bwidget == 1} {
|
|
|
|
set text \
|
|
"${text}The file tree browser presents to you a directory tree and
|
|
lets you bring into effect one of the file addresses in that tree.\n"
|
|
|
|
} else {
|
|
|
|
set text \
|
|
"${text}Normally the file tree browser would present to you a directory tree
|
|
and let you bring into effect one of the file addresses in that tree.
|
|
|
|
But the tree view cannot be displayed because Tcl/Tk package \"BWidget\"
|
|
is not loaded.
|
|
|
|
-------------------------------------------------------------------------\n"
|
|
|
|
}
|
|
|
|
set text "${text}
|
|
The bottom line of the browser window tells the associated text field
|
|
in the GUI. E.g. \"ISO directory:\".
|
|
Left of this label is a copy of that associated text field. You may edit
|
|
its content and bring it into effect by hitting the Return key.\n"
|
|
|
|
if {$have_bwidget == 1} {
|
|
|
|
set text "${text}
|
|
In the tree display click on the \"+\" resp. \"-\" nodes to open resp.
|
|
close directories.
|
|
|
|
Double click on an item to bring it into effect with the associated
|
|
text field. I.e. double clicking also hits the Return key in that field.\n"
|
|
|
|
}
|
|
|
|
set text "${text}
|
|
The \"Accept\" button does the same with the selected item.\n"
|
|
|
|
if {$have_bwidget == 1} {
|
|
|
|
set text "${text}
|
|
The \"Edit\" button brings the selected item into the text field
|
|
without hitting the Return key. So you may edit the name before hitting
|
|
Return yourself.
|
|
|
|
The \"Up\" button brings you to the parent directory of the selected item.
|
|
|
|
The \"Down\" button works like clicking the \"+\" node of the selected item.\n"
|
|
|
|
}
|
|
|
|
set text "${text}
|
|
The \"Help\" button displays this help text window.
|
|
|
|
The \"Close\" button closes the browser window.\n"
|
|
|
|
if {$have_bwidget == 1} {
|
|
|
|
set text "${text}
|
|
If the \"File browser text field\" switch is enabled then a single click
|
|
or a cursor movement by the arrow keys brings the selected item into
|
|
the associated text field, but does not hit the Return key."
|
|
|
|
}
|
|
return $text
|
|
}
|
|
|
|
|
|
# Tell about pecliarity of help window triggered by yes/no window
|
|
proc about_help_for_yesno {} {
|
|
return \
|
|
"---------------------------------------------------------------------------
|
|
|
|
It is impossible to trigger any further GUI action while the confirmation
|
|
window is displayed. You have to click one of the buttons in that window.
|
|
|
|
You cannot even close this help window before you clicked one of the buttons."
|
|
}
|
|
|
|
|
|
# ------- Misc helper procedures -------
|
|
|
|
|
|
# Equip a text with quotation marks so that xorriso will consider it as
|
|
# a single word.
|
|
#
|
|
proc make_text_shellsafe {text} {
|
|
set result "'"
|
|
set rest $text
|
|
while {[string length $rest]} {
|
|
set idx [string first "'" $rest]
|
|
if {$idx == -1} {
|
|
set result "$result$rest"
|
|
break
|
|
} else {
|
|
if {$idx > 0} {
|
|
set result "$result[string range $rest 0 [expr $idx - 1]]"
|
|
}
|
|
set result "$result'\"'\"'"
|
|
if {$idx == [expr [string length $rest] - 1]} {
|
|
break
|
|
}
|
|
set rest [string range $rest [expr $idx + 1] end]
|
|
}
|
|
}
|
|
set result "$result'"
|
|
}
|
|
|
|
|
|
# Count the number of newline chracters in text.
|
|
#
|
|
proc count_newlines {text} {
|
|
set rest $text
|
|
set count 0
|
|
while {[string length $rest]} {
|
|
set idx [string first "\n" $rest]
|
|
if {$idx == -1} {
|
|
break
|
|
} else {
|
|
set count [expr $count + 1]
|
|
if {$idx == [expr [string length $rest] - 1]} {
|
|
break
|
|
}
|
|
set rest [string range $rest [expr $idx + 1] end]
|
|
}
|
|
}
|
|
return $count
|
|
}
|
|
|
|
|
|
# Append name to dir so that the result is a path to name under dir.
|
|
#
|
|
proc combine_dir_and_name {dir name} {
|
|
set has_slash 0
|
|
if {$name == ""} {
|
|
return $dir
|
|
}
|
|
if {[string range $name 0 0] == "/"} {
|
|
incr has_slash
|
|
}
|
|
if {[string last "/" $dir] == [expr [string length $dir] - 1] &&
|
|
$dir != ""} {
|
|
incr has_slash 1
|
|
}
|
|
if {$has_slash == 2} {
|
|
return "$dir[string range $name" 1 end]"
|
|
}
|
|
if {$has_slash == 1} {
|
|
return "$dir$name"
|
|
}
|
|
return "$dir/$name"
|
|
}
|
|
|
|
|
|
# Force the content of variable isodir_adr to be an absolute address
|
|
#
|
|
proc normalize_isodir_adr {} {
|
|
global isodir_adr
|
|
|
|
if {$isodir_adr == ""} {
|
|
set isodir_adr "/"
|
|
}
|
|
if {[string range $isodir_adr 0 0] != "/"} {
|
|
set isodir_adr "/$isodir_adr"
|
|
}
|
|
}
|
|
|
|
|
|
# Inspect path whether one of its components is in isodir_adr
|
|
#
|
|
proc path_touches_isodir {path} {
|
|
global isodir_adr
|
|
|
|
normalize_isodir_adr
|
|
set cmp_start 0
|
|
if {$isodir_adr == "/"} {
|
|
set cmp_start 1
|
|
}
|
|
if {[string range $path 0 0] != "/"} {
|
|
if {[string first "/" $path] == -1} {
|
|
return $path
|
|
} else {
|
|
return [file dirname $path]
|
|
}
|
|
}
|
|
set l [expr {[string length $isodir_adr] - $cmp_start}]
|
|
if {[string length $path] < [expr {$l + 2}]} {
|
|
return ""
|
|
}
|
|
if {$l > 0} {
|
|
if {[string range $path $cmp_start [expr {$l - 1}]] != \
|
|
[string range $isodir_adr $cmp_start end]} {
|
|
return ""
|
|
}
|
|
}
|
|
if {[string range $path $l $l] != "/"} {
|
|
return ""
|
|
}
|
|
set subpath [string range $path [expr {$l + 1}] end]
|
|
set slash [string first "/" $subpath]
|
|
if {$slash == -1} {
|
|
return $subpath
|
|
}
|
|
if {$slash == 0} {
|
|
return ""
|
|
}
|
|
return [string range $subpath 0 [expr {$slash - 1}]]
|
|
}
|
|
|
|
|
|
# Compare two severity names by help of the severity list that was obtained
|
|
# from xorriso via proc inquire_severity_list.
|
|
#
|
|
proc compare_sev {sev1 sev2} {
|
|
global xorriso_severity_list
|
|
|
|
set idx1 [lsearch -exact $xorriso_severity_list $sev1]
|
|
set idx2 [lsearch -exact $xorriso_severity_list $sev2]
|
|
if {$idx1 < $idx2} {return -1}
|
|
if {$idx1 > $idx2} {return 1}
|
|
return 0
|
|
}
|
|
|
|
|
|
# Write a text to the pipe log
|
|
#
|
|
proc debug_log_puts {text} {
|
|
global debug_logging debug_log_conn
|
|
|
|
if {$debug_logging == 1} {
|
|
puts $debug_log_conn $text
|
|
flush $debug_log_conn
|
|
}
|
|
}
|
|
|
|
|
|
# End program and return the given exit value.
|
|
#
|
|
proc central_exit {value} {
|
|
exit $value
|
|
}
|
|
|
|
|
|
# Start a xorriso process which will in return launch another frontend
|
|
# process. This is necessary until i learned how to create a pair of pipes
|
|
# and to fork in Tcl.
|
|
#
|
|
proc start_xorriso {} {
|
|
global argv0 argv
|
|
|
|
set self ""
|
|
if {[string first "/" $argv0] != -1} {
|
|
set self $argv0
|
|
}
|
|
if {$self == ""} {
|
|
set self "/usr/bin/xorriso-tcltk"
|
|
if {[file executable $self] == 0} {set self ""}
|
|
}
|
|
if {$self == ""} {
|
|
set self "/usr/local/bin/xorriso-tcltk"
|
|
if {[file executable $self] == 0} {set self ""}
|
|
}
|
|
if {$self == ""} {
|
|
catch {
|
|
set conn [open "|which xorriso-tcltk" r]
|
|
set self [gets $conn]
|
|
close $conn
|
|
}
|
|
}
|
|
if {$self == ""} {
|
|
catch {
|
|
set conn [open "|sh -c \"type -p xorriso-tcltk\"" r]
|
|
set self [gets $conn]
|
|
close $conn
|
|
}
|
|
}
|
|
if {$self == ""} {
|
|
puts stderr "$argv0 :\n Cannot locate address of script xorriso-tcltk in filesystem.\n"
|
|
puts stderr "You will have to use --stdio or --named_pipes."
|
|
puts stderr "See $argv0 --help\n"
|
|
central_exit 1
|
|
}
|
|
|
|
# eval is used to split $argv into single words
|
|
eval exec xorriso -launch_frontend "\"$self\"" --silent_start --stdio $argv -- 2>@stderr
|
|
|
|
central_exit 0
|
|
}
|
|
|
|
|
|
# Print a startup message to stderr if not the first argument is --silent_start
|
|
#
|
|
proc yell_xorriso_tcltk {} {
|
|
global argv own_version
|
|
|
|
if {[llength $argv] > 0} {
|
|
if {[lindex $argv 0] == "--silent_start"} {return ""}
|
|
}
|
|
puts stderr "xorriso-tcltk $own_version : Proof of concept for GUI frontends of xorriso\n"
|
|
}
|
|
|
|
|
|
# Tells whether an absolute path leads to a directory on hard disk
|
|
#
|
|
proc localfs_filetype {path} {
|
|
catch {file lstat $path stbuf}
|
|
if {[info exists stbuf] == 1} {
|
|
set t [string range $stbuf(type) 0 0]
|
|
if {[string first $t "bcdls"] != -1} {return $t}
|
|
if {$stbuf(type) == "file"} {return "-"}
|
|
if {$stbuf(type) == "fifo"} {return "p"}
|
|
return "?"
|
|
}
|
|
return ""
|
|
}
|
|
|
|
|
|
# Return the list of files of a hard disk filesystem directory
|
|
#
|
|
proc localfs_ls {dir} {
|
|
|
|
set result ""
|
|
if {[localfs_filetype $dir] != "d"} {return ""}
|
|
set conn [open "|ls {$dir}" r]
|
|
while {1} {
|
|
set ret [gets $conn line]
|
|
if {$ret == -1} {
|
|
break
|
|
}
|
|
set adr [combine_dir_and_name $dir $line]
|
|
set filetype [localfs_filetype $adr]
|
|
if {$filetype == ""} {set filetype "?"}
|
|
lappend result "$filetype $line"
|
|
}
|
|
catch {close $conn}
|
|
return $result
|
|
}
|
|
|
|
|
|
# Log a command (if enabled)
|
|
#
|
|
proc log_command {cmd} {
|
|
global cmd_log_conn cmd_logging_mode recent_cd_path
|
|
|
|
if {$cmd_logging_mode < 1} {return ""}
|
|
|
|
if {[string first "-cd " $cmd] == 0} {
|
|
set path [string range $cmd 4 end]
|
|
if {$path == $recent_cd_path} {return ""}
|
|
set recent_cd_path $path
|
|
}
|
|
|
|
if {$cmd_log_conn == ""} {
|
|
effectuate_command_logging 0
|
|
if {$cmd_logging_mode < 1} {return ""}
|
|
}
|
|
set prefix ""
|
|
if {$cmd_logging_mode == 1} {
|
|
if {[string first "-osirrox" $cmd] != -1 || \
|
|
[string first "-extract" $cmd] != -1} {
|
|
set prefix "# "
|
|
}
|
|
}
|
|
puts $cmd_log_conn $prefix$cmd
|
|
flush $cmd_log_conn
|
|
}
|
|
|
|
|
|
# Start command logging
|
|
# Called by setup_by_args and by the "Script/Log" menu.
|
|
# (target == "." and mode == -1 preserve the current state.)
|
|
#
|
|
proc start_command_logging {target mode} {
|
|
global cmd_log_conn cmd_logging_mode msglist_running cmd_log_target
|
|
|
|
set is_stderr 0
|
|
if {$cmd_log_target == "" || $cmd_log_target == "-" || \
|
|
$cmd_log_conn == "stderr"} {set is_stderr 1}
|
|
set errmsg ""
|
|
if {$target != "." && $cmd_log_conn != "" && $target != $cmd_log_target && \
|
|
$is_stderr == 0} {
|
|
catch "close $cmd_log_conn"
|
|
set cmd_log_conn ""
|
|
}
|
|
set ret 0
|
|
if {$cmd_log_conn == "" || $is_stderr == 1} {
|
|
if {$target == "-" || $target == "" || $target == "."} {
|
|
set cmd_log_conn stderr
|
|
} else {
|
|
set ret [catch {set cmd_log_conn [open $target a]} errmsg]
|
|
}
|
|
if {$target != "."} {
|
|
set cmd_log_target $target
|
|
}
|
|
}
|
|
if {$ret == 0 && $mode >= 0} {
|
|
set cmd_logging_mode $mode
|
|
}
|
|
if {$ret == 1} {
|
|
set msg "xorriso-tcltk : SORRY : Failed to open command log script [make_text_shellsafe $target] :\n$errmsg"
|
|
if {$msglist_running == 1} {
|
|
xorriso_tcltk_errmsg $msg
|
|
} else {
|
|
puts stderr $msg
|
|
}
|
|
set cmd_logging_mode 0
|
|
return 0
|
|
}
|
|
if {$mode > 0} {
|
|
puts $cmd_log_conn "# xorriso-tcltk command log script"
|
|
puts $cmd_log_conn [xorriso_loggable_init_cmds]
|
|
flush $cmd_log_conn
|
|
}
|
|
return 1
|
|
}
|
|
|
|
|
|
# Start communications pipe logging
|
|
# Called by setup_by_args and by the "Script/Log" menu.
|
|
# (target == "." and mode == -1 preserve the current state.)
|
|
#
|
|
proc start_debug_logging {target mode} {
|
|
global debug_log_conn debug_log_file debug_logging msglist_running
|
|
|
|
set is_stderr 0
|
|
if {$debug_log_file == "" || $debug_log_file == "-" || \
|
|
$debug_log_conn == "stderr"} {set is_stderr 1}
|
|
set errmsg ""
|
|
if {$target != "." && $debug_log_conn != "" && \
|
|
$target != $debug_log_file && $is_stderr == 0} {
|
|
catch "close $debug_log_conn"
|
|
set debug_log_conn ""
|
|
}
|
|
set ret 0
|
|
if {$debug_log_conn == "" || $is_stderr == 1} {
|
|
if {$target == "-" || $target == "" || $target == "."} {
|
|
set debug_log_conn stderr
|
|
} else {
|
|
set ret [catch {set debug_log_conn [open $target a]} errmsg]
|
|
}
|
|
if {$target != "."} {
|
|
set debug_log_file $target
|
|
}
|
|
}
|
|
if {$ret == 0 && $mode >= 0} {
|
|
set debug_logging $mode
|
|
}
|
|
if {$ret == 1} {
|
|
set msg "xorriso-tcltk : SORRY : Failed to open pipe log [make_text_shellsafe $target] :\n$errmsg"
|
|
if {$msglist_running == 1} {
|
|
xorriso_tcltk_errmsg $msg
|
|
} else {
|
|
puts stderr $msg
|
|
}
|
|
return 0
|
|
}
|
|
return 1
|
|
}
|
|
|
|
|
|
proc execute_script {close_window} {
|
|
global execute_script_conn execute_script_adr browse_disk_window_is_active
|
|
global osirrox_allowed script_with_osirrox cmd_logging_mode cmd_log_target
|
|
global highest_cmd_sev
|
|
|
|
if {$close_window == 1 && $browse_disk_window_is_active == 1} {
|
|
destroy_browse_disk .browse_disk_window
|
|
}
|
|
|
|
set n1 [file normalize $execute_script_adr]
|
|
set n2 [file normalize $cmd_log_target]
|
|
if {$n1 == $n2 && $cmd_logging_mode > 0} {
|
|
xorriso_tcltk_errmsg "xorriso-tcltk : SORRY : You first have to disable command script logging before using the log script"
|
|
return ""
|
|
}
|
|
|
|
set errmsg ""
|
|
set ret [catch {set execute_script_conn [open $execute_script_adr r]} errmsg]
|
|
if {$ret != 0} {
|
|
xorriso_tcltk_errmsg "xorriso-tcltk : SORRY : Failed to open command script [make_text_shellsafe $execute_script_adr] :\n$errmsg"
|
|
return ""
|
|
}
|
|
set line ""
|
|
set ret [gets $execute_script_conn line]
|
|
if {$ret < 0 || $line != "# xorriso-tcltk command log script"} {
|
|
xorriso_tcltk_errmsg "xorriso-tcltk : SORRY : Given file does not look like a xorriso command log script"
|
|
close $execute_script_conn
|
|
return ""
|
|
}
|
|
|
|
# >>> ??? Show script
|
|
|
|
if {[window_yesno "Really perform the xorriso commands in file\n\n[make_text_shellsafe $execute_script_adr]\n\n?"] != 1} {
|
|
close $execute_script_conn
|
|
return ""
|
|
}
|
|
if {$script_with_osirrox != 1} {
|
|
send_silent_cmd "-osirrox blocked"
|
|
}
|
|
while {1} {
|
|
set ret [gets $execute_script_conn line]
|
|
if {$ret < 0} {
|
|
break
|
|
}
|
|
if {$line == "" || [string first "#" $line] == 0} {
|
|
continue
|
|
}
|
|
reset_highest_cmd_sev
|
|
send_loggable_cmd $line
|
|
if {[compare_sev $highest_cmd_sev "FAILURE"] >= 0} {
|
|
xorriso_tcltk_errmsg "xorriso-tcltk : SORRY : Encountered problem event of severity '$highest_cmd_sev'.\nScript execution aborted."
|
|
break
|
|
}
|
|
}
|
|
close $execute_script_conn
|
|
if {$script_with_osirrox != 1} {
|
|
send_silent_cmd "-osirrox unblock"
|
|
}
|
|
}
|
|
|
|
|
|
# Convert newline into \n
|
|
#
|
|
proc escape_newline {text} {
|
|
return [string map [list "\n" "\\n"] $text]
|
|
}
|
|
|
|
|
|
# -------- start living
|
|
|
|
|
|
proc setup_by_args {argv0 argv} {
|
|
global cmd_pipe_adr reply_pipe_adr main_window_geometry click_to_focus
|
|
global have_bwidget cmd_conn reply_conn geometry stdout stdin
|
|
|
|
# wish normally eats the -geometry option and puts the result into $geometry
|
|
catch {set main_window_geometry $geometry}
|
|
|
|
set connection_defined 0
|
|
|
|
set loop_limit [llength $argv]
|
|
for {set i 0} {$i < $loop_limit} {incr i} {
|
|
set ok "0"
|
|
set opt [lrange $argv $i $i]
|
|
if {$opt == "--help"} {
|
|
set ok "1"
|
|
print_usage $argv0
|
|
central_exit 0
|
|
}
|
|
if {$opt == "--silent_start"} {
|
|
set ok "1"
|
|
}
|
|
if {$opt == "--stdio"} {
|
|
set ok "1"
|
|
set connection_defined 1
|
|
}
|
|
if {$opt == "--named_pipes"} {
|
|
set ok "1"
|
|
incr i
|
|
set cmd_pipe_adr [lrange $argv $i $i]
|
|
incr i
|
|
set reply_pipe_adr [lrange $argv $i $i]
|
|
if {$cmd_pipe_adr != "" && $reply_pipe_adr != "" &&
|
|
$cmd_pipe_adr != "-" && $reply_pipe_adr != "-"} {
|
|
init_frontend_named_pipes $cmd_pipe_adr $reply_pipe_adr
|
|
}
|
|
set connection_defined 1
|
|
}
|
|
if {$opt == "--geometry" || $opt == "-geometry"} {
|
|
set ok "1"
|
|
# Just in case -geometry does not get eaten by wish
|
|
incr i
|
|
set main_window_geometry [lrange $argv $i $i]
|
|
set give_geometry [lrange $argv $i $i]
|
|
}
|
|
if {$opt == "--click_to_focus"} {
|
|
set ok "1"
|
|
set click_to_focus "1"
|
|
}
|
|
if {$opt == "--auto_focus"} {
|
|
set ok "1"
|
|
set click_to_focus "0"
|
|
}
|
|
if {$opt == "--pipe_log_file"} {
|
|
set ok "1"
|
|
incr i
|
|
set name [lrange $argv $i $i]
|
|
set ret [start_debug_logging $name 1]
|
|
if {$ret <= 0} {
|
|
puts stderr \
|
|
"$argv0 : Cannot open --pipe_log_file '$debug_log_file' for writing"
|
|
central_exit 2
|
|
}
|
|
}
|
|
if {$opt == "--script_log_file"} {
|
|
set ok "1"
|
|
incr i
|
|
set name [lrange $argv $i $i]
|
|
set ret [start_command_logging $name 1]
|
|
if {$ret <= 0} {
|
|
puts stderr \
|
|
"$argv0 : Cannot open --script_log_file '$name' for writing"
|
|
central_exit 2
|
|
}
|
|
}
|
|
if {$opt == "--no_bwidget"} {
|
|
set ok "1"
|
|
set have_bwidget "-1"
|
|
}
|
|
if {$ok == 0} {
|
|
puts stderr "$argv0 : Unknown option '$opt'"
|
|
print_usage $argv0
|
|
central_exit 1
|
|
}
|
|
}
|
|
|
|
if {$connection_defined == 0} {
|
|
start_xorriso
|
|
}
|
|
|
|
if {$cmd_pipe_adr == "" || $reply_pipe_adr == "" ||
|
|
$cmd_pipe_adr == "-" || $reply_pipe_adr == "-"} {
|
|
set cmd_conn stdout
|
|
set reply_conn stdin
|
|
}
|
|
if {$main_window_geometry != ""} {
|
|
wm geometry . $main_window_geometry
|
|
}
|
|
}
|
|
|
|
yell_xorriso_tcltk
|
|
|
|
setup_by_args $argv0 $argv
|
|
check_xorriso_version
|
|
setup_xorriso
|
|
|
|
init_gui
|
|
|
|
display_busy 0
|
|
refresh_state
|
|
|