5839 lines
178 KiB
Tcl
Executable File
5839 lines
178 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.7"
|
|
|
|
# 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.7"
|
|
|
|
|
|
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_extract"
|
|
puts stderr " Do not allow extraction of files from ISO filesystem to"
|
|
puts stderr " hard disk. This is not revokable during the program run."
|
|
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 ----------------------------
|
|
#
|
|
# Connects to a xorriso process, 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
|
|
|
|
# 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 result of the most recent localfs_ls run
|
|
set localfs_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 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 0]
|
|
}
|
|
if {[compare_sev $sev $highest_cmd_sev] >= 0} {
|
|
set highest_cmd_sev $sev
|
|
set highest_cmd_sev_msg [escape_newline $line 0]
|
|
}
|
|
}
|
|
|
|
|
|
# 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.
|
|
# This is a precondition for writing the session. Vice versa pending changes
|
|
# block a change of the input drive or the program end.
|
|
#
|
|
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 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 result_count scan_event_threshold
|
|
|
|
set scan_event_mem $scan_event_threshold
|
|
set scan_event_threshold "SORRY"
|
|
send_silent_cmd "-lsdl [make_text_shellsafe $path]"
|
|
set scan_event_threshold $scan_event_mem
|
|
if {$result_count < 1} {return ""}
|
|
return [string range [lindex $result_list 0] 0 0]
|
|
}
|
|
|
|
|
|
# Inspection of hard disk is done via xorriso.
|
|
# The xorriso commands have the advantage to be always available and to
|
|
# need no unescaping. On the other hand, shell and tcl lstat would be
|
|
# faster with large directories.
|
|
|
|
# Parse-by-xorriso handler function for proc localfs_ls
|
|
#
|
|
proc localfs_ls_handler {} {
|
|
global result_list localfs_ls_result
|
|
|
|
if {[lindex $result_list 0] == "total"} {return ""}
|
|
lappend localfs_ls_result \
|
|
"[string range [lindex $result_list 0] 0 0] [lindex $result_list 8]"
|
|
}
|
|
|
|
|
|
# Return the list of files of a hard disk filesystem directory
|
|
#
|
|
proc localfs_ls {dir} {
|
|
global localfs_ls_result
|
|
|
|
set localfs_ls_result ""
|
|
if {[localfs_filetype $dir] != "d"} {return ""}
|
|
|
|
set disp_en_mem [set_display_msg 0]
|
|
send_marked_cmd "-lslx [make_text_shellsafe $dir]"
|
|
handle_result_list localfs_ls_handler "''" "''" 0 0
|
|
set_display_msg $disp_en_mem
|
|
return $localfs_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 localfs_filetype {path} {
|
|
global result_list result_count scan_event_threshold
|
|
|
|
set scan_event_mem $scan_event_threshold
|
|
set scan_event_threshold "SORRY"
|
|
send_silent_cmd "-lsdlx [make_text_shellsafe $path]"
|
|
set scan_event_threshold $scan_event_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 {} {
|
|
global osirrox_allowed
|
|
|
|
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"
|
|
|
|
if {$osirrox_allowed == 0} {
|
|
set cmd "$cmd -osirrox banned"
|
|
}
|
|
|
|
set cmd "$cmd [xorriso_loggable_init_cmds]"
|
|
|
|
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 -backslash_codes on"
|
|
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.
|
|
|
|
|
|
# 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_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
|
|
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 bulk parser job.
|
|
#
|
|
proc submit_bulkparse {text} {
|
|
global cmd_conn reply_conn
|
|
global result_list result_count
|
|
global bulk_parse_prefix bulk_parse_separators
|
|
global bulk_parse_max_words bulk_parse_flag
|
|
|
|
set disp_en_mem [set_display_msg 0]
|
|
|
|
set num_lines [expr [count_newlines $text] + 1]
|
|
|
|
debug_log_puts ">>>>> $num_lines"
|
|
puts $cmd_conn $num_lines
|
|
debug_log_puts ">>>>> $text"
|
|
puts $cmd_conn $text
|
|
flush $cmd_conn
|
|
set_display_msg $disp_en_mem
|
|
}
|
|
|
|
|
|
# Read the expected number of bulk parsing 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} {
|
|
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 sieve_result_count 0
|
|
set payload ""
|
|
set num_lines 0
|
|
set acc ""
|
|
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
|
|
set line [lindex $result_list [expr $result_count-1]]
|
|
if {$result_count == 1} {
|
|
set parse_ret $line
|
|
} else { if {$result_count == 2} {
|
|
set num_replies $line
|
|
# The minimum number of lines
|
|
set loop_limit [expr "$num_replies * 2 + 2"]
|
|
} else {
|
|
if {$num_lines <= 0} {
|
|
set num_lines $line
|
|
if {$num_lines > 1} {
|
|
# Need to read extra lines
|
|
incr loop_limit [expr $num_lines-1]
|
|
}
|
|
set acc ""
|
|
} else {
|
|
incr num_lines -1
|
|
if {$acc != ""} {
|
|
set acc "$acc\n$line"
|
|
} else {
|
|
set acc $line
|
|
}
|
|
if {$num_lines <= 0} {
|
|
lappend payload $acc
|
|
incr sieve_result_count
|
|
}
|
|
}
|
|
}}
|
|
}
|
|
set result_list $payload
|
|
set result_count $sieve_result_count
|
|
}
|
|
|
|
|
|
# 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_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 {$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 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_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"} { 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 [isofs_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 [isofs_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_profile eff_outdev_adr eff_indev_adr
|
|
|
|
refresh_outdev
|
|
if {[assert_outdev blanking] <= 0} {return ""}
|
|
|
|
if {$eff_outdev_adr == $eff_indev_adr} {
|
|
if {[assert_no_changes] <= 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 $eff_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_profile eff_outdev_adr eff_indev_adr
|
|
|
|
refresh_outdev
|
|
if {[assert_outdev formatting] <= 0} {return ""}
|
|
if {$eff_outdev_adr == $eff_indev_adr} {
|
|
if {[assert_no_changes] <= 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 $eff_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 directory on hard disk by file of other type\n[make_text_shellsafe $target]"
|
|
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\" for\n[make_text_shellsafe $target]"
|
|
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\" for\n[make_text_shellsafe $target]"
|
|
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 [isofs_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 [isofs_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 already 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 eff_outdev_adr
|
|
|
|
inquire_dev
|
|
if {$eff_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
|
|
|
|
set m ".script_log.menu"
|
|
$m entryconfigure "Allow extract to disk" -state "disabled"
|
|
$m entryconfigure "Permanently ban extraction" -state "disabled"
|
|
|
|
.extract_button configure -state "disabled"
|
|
|
|
}
|
|
|
|
|
|
# ------ 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
|
|
set parent_dir /
|
|
} else {
|
|
set parent_name [escape_to_tree $parent]
|
|
set parent_dir $parent_name
|
|
}
|
|
if {[$tr exists $parent_name] == 0} {return ""}
|
|
|
|
$tr delete [$tr nodes $parent_name]
|
|
|
|
foreach i $children {
|
|
set name [string range $i 2 end]
|
|
set escpd [escape_to_tree $name]
|
|
set adr [combine_dir_and_name $parent_dir $escpd]
|
|
$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 double-clicks a node.
|
|
#
|
|
proc browse_tree_accept {adr_var_name do_return tr value} {
|
|
global have_bwidget
|
|
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
|
|
|
|
# Caution: Before using $tr, check for $have_bwidget
|
|
|
|
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_accept |