3224 lines
90 KiB
Plaintext
3224 lines
90 KiB
Plaintext
|
#!/usr/bin/wish
|
||
|
|
#
|
||
|
|
# xorriso-tcltk
|
||
|
|
# Copyright (C) 2012, Thomas Schmitt <scdbackup@gmx.net>, libburnia project.
|
||
|
|
# Provided under GNU GPL version 2 or later.
|
||
|
|
#
|
||
|
|
# 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"
|
||
|
|
|
||
|
|
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 " Establishes 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 " Establishes 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 " --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."
|
||
|
|
puts stderr " --auto_focus"
|
||
|
|
puts stderr " Chooses that the keyboard focus is where the mouse"
|
||
|
|
puts stderr " pointer is. (Default)"
|
||
|
|
puts stderr " --log_file path"
|
||
|
|
puts stderr " Set a file address for logging of xorriso commands and"
|
||
|
|
puts stderr " reply messages. The log lines will be appended."
|
||
|
|
puts stderr ""
|
||
|
|
puts stderr "Either --stdio or --named_pipes must be given for a program run."
|
||
|
|
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)
|
||
|
|
set outdev_adr ""
|
||
|
|
set 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 ISO and on disk is allowed
|
||
|
|
set overwrite_files 1
|
||
|
|
|
||
|
|
# If overwrite_files is 1 : Wether overwriting of ISO directories is allowed
|
||
|
|
set overwrite_dirs 0
|
||
|
|
|
||
|
|
# The file where to log commands and replies for debugging purposes
|
||
|
|
set log_file ""
|
||
|
|
set log_conn stderr
|
||
|
|
|
||
|
|
# Whether to log all commands and replies to the log_file
|
||
|
|
set logging 0
|
||
|
|
|
||
|
|
|
||
|
|
# 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 logging log_conn
|
||
|
|
|
||
|
|
display_busy 1
|
||
|
|
|
||
|
|
log_puts " =============================================================="
|
||
|
|
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"
|
||
|
|
log_puts " $mark_cmd"
|
||
|
|
puts $cmd_conn "$mark_cmd"
|
||
|
|
flush $cmd_conn
|
||
|
|
await_all_replies
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
# 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
|
||
|
|
}
|
||
|
|
log_puts "$line"
|
||
|
|
if {[string range "$line" 0 0] == "M"} {
|
||
|
|
if {[string range "$line" 5 end] == "$mark_count"} {
|
||
|
|
|
||
|
|
# <<<
|
||
|
|
# puts stderr "sync mark"
|
||
|
|
|
||
|
|
break
|
||
|
|
} else {
|
||
|
|
# outdated mark message
|
||
|
|
continue
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
de_pkt_line "$line"
|
||
|
|
}
|
||
|
|
|
||
|
|
display_busy 0
|
||
|
|
|
||
|
|
# <<< debug
|
||
|
|
# for {set i 0} {$i < $info_count} {incr i} {
|
||
|
|
# set line [lindex "$info_list" $i]
|
||
|
|
# puts stderr "info $i : $line"
|
||
|
|
# }
|
||
|
|
# for {set i 0} {$i < $result_count} {incr i} {
|
||
|
|
# set line [lindex "$result_list" $i]
|
||
|
|
# puts stderr "result $i : $line"
|
||
|
|
# }
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
# 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"
|
||
|
|
|
||
|
|
# <<<
|
||
|
|
# puts stderr "result: $emerging_result"
|
||
|
|
|
||
|
|
set emerging_result ""
|
||
|
|
} else {
|
||
|
|
lappend info_list "$emerging_info"
|
||
|
|
incr info_count
|
||
|
|
display_msg "$emerging_info"
|
||
|
|
scan_info_for_event "$emerging_info"
|
||
|
|
|
||
|
|
# <<<
|
||
|
|
# puts stderr "info: $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 "$line"
|
||
|
|
}
|
||
|
|
if {[compare_sev "$sev" "$highest_cmd_sev"] >= 0} {
|
||
|
|
set highest_cmd_sev "$sev"
|
||
|
|
set highest_cmd_sev_msg "$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]
|
||
|
|
|
||
|
|
# <<<
|
||
|
|
# puts stderr "de_sieve : num_lines = $num_lines"
|
||
|
|
|
||
|
|
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
|
||
|
|
}
|
||
|
|
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 {} {
|
||
|
|
set disp_en_mem [set_display_msg 0]
|
||
|
|
send_marked_cmd "-msg_op clear_sieve -"
|
||
|
|
set_display_msg "$disp_en_mem"
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
# Obtain a recorded item from the xorriso message sieve.
|
||
|
|
#
|
||
|
|
proc read_sieve {name} {
|
||
|
|
set disp_en_mem [set_display_msg 0]
|
||
|
|
send_marked_cmd "-msg_op read_sieve '$name'"
|
||
|
|
set_display_msg "$disp_en_mem"
|
||
|
|
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
|
||
|
|
|
||
|
|
set disp_en_mem [set_display_msg 0]
|
||
|
|
send_marked_cmd "-changes_pending show_status"
|
||
|
|
set_display_msg "$disp_en_mem"
|
||
|
|
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"
|
||
|
|
set disp_en_mem [set_display_msg 0]
|
||
|
|
send_marked_cmd "-lsdl [make_text_shellsafe "$adr"] --"
|
||
|
|
set_display_msg "$disp_en_mem"
|
||
|
|
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 disp_en_mem [set_display_msg 0]
|
||
|
|
set highest_seen_cmd_sev ""
|
||
|
|
set set_mem "$scan_event_threshold"
|
||
|
|
set scan_event_threshold "FATAL"
|
||
|
|
send_marked_cmd "-lsd / --"
|
||
|
|
set scan_event_threshold "$set_mem"
|
||
|
|
set_display_msg "$disp_en_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 indev_adr outdev_adr
|
||
|
|
|
||
|
|
if {[llength "$result_list"] < 2} {return ""}
|
||
|
|
set what [lindex "$result_list" 0]
|
||
|
|
if {"$what" == "-dev" || "$what" == "-indev"} {
|
||
|
|
set indev_adr [lindex "$result_list" 1]
|
||
|
|
}
|
||
|
|
if {"$what" == "-dev" || "$what" == "-outdev"} {
|
||
|
|
set outdev_adr [lindex "$result_list" 1]
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
# Inquire -indev and -outdev from xorriso and install in indev_adr
|
||
|
|
# and outdev_adr. Usually called when the user messed up the text fields.
|
||
|
|
# (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 {} {
|
||
|
|
global result_list
|
||
|
|
|
||
|
|
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 ""
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
# 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
|
||
|
|
global reply_conn
|
||
|
|
|
||
|
|
set min_version "1.2.5"
|
||
|
|
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_version"} {
|
||
|
|
puts stderr "xorriso-tcltk: xorriso-$xorriso_version is too old."
|
||
|
|
puts stderr "xorriso-tcltk: Need at least version $min_version"
|
||
|
|
window_ack \
|
||
|
|
"xorriso-$xorriso_version is too old. Need at least version $min_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 -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 -abort_on NEVER"
|
||
|
|
set cmd "$cmd -report_about UPDATE"
|
||
|
|
set cmd "$cmd -osirrox on"
|
||
|
|
set cmd "$cmd -iso_rr_pattern off"
|
||
|
|
set cmd "$cmd -disk_pattern off"
|
||
|
|
|
||
|
|
send_marked_cmd "$cmd"
|
||
|
|
|
||
|
|
inquire_severity_list
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
# ------ 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\""
|
||
|
|
|
||
|
|
# <<<
|
||
|
|
# puts stderr "start_bulkparse : $cmd"
|
||
|
|
|
||
|
|
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\""
|
||
|
|
|
||
|
|
# <<<
|
||
|
|
# puts stderr "submit_bulkparse: cmd = $cmd"
|
||
|
|
|
||
|
|
send_async_cmd "$cmd"
|
||
|
|
} else {
|
||
|
|
log_puts ">>>>> $num_lines"
|
||
|
|
puts $cmd_conn "$num_lines"
|
||
|
|
}
|
||
|
|
log_puts ">>>>> $text"
|
||
|
|
puts $cmd_conn "$text"
|
||
|
|
flush $cmd_conn
|
||
|
|
|
||
|
|
# <<<
|
||
|
|
# puts stderr "submit_bulkparse: text sent"
|
||
|
|
|
||
|
|
if {"$bulk_parse_mode" != 1} {
|
||
|
|
|
||
|
|
set loop_limit 2
|
||
|
|
while {"$result_count" < "$loop_limit"} {
|
||
|
|
set ret [gets "$reply_conn" line]
|
||
|
|
if {"$ret" < 0} { return ""}
|
||
|
|
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"]
|
||
|
|
|
||
|
|
# <<<
|
||
|
|
# puts stderr "submit_bulkparse: loop_limit = $loop_limit"
|
||
|
|
|
||
|
|
}
|
||
|
|
}
|
||
|
|
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]
|
||
|
|
|
||
|
|
# <<<
|
||
|
|
# puts stderr "read_bulkparse : handler_proc = $handler_proc , num_texts = $num_texts"
|
||
|
|
|
||
|
|
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 ""}
|
||
|
|
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"]
|
||
|
|
|
||
|
|
# <<<
|
||
|
|
# puts stderr "submit_bulkparse: loop_limit = $loop_limit"
|
||
|
|
|
||
|
|
}
|
||
|
|
}
|
||
|
|
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 iall 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"
|
||
|
|
|
||
|
|
# <<<
|
||
|
|
# puts stderr "isodir_return : chunk_size = $chunk_size"
|
||
|
|
|
||
|
|
set submit_count 0
|
||
|
|
set submit_in_chunk_count 0
|
||
|
|
foreach i "$raw_list" {
|
||
|
|
# <<<
|
||
|
|
# puts stderr "isodir_return : submit_bulkparse $i"
|
||
|
|
|
||
|
|
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"} {
|
||
|
|
|
||
|
|
# <<<
|
||
|
|
# puts stderr "isodir_return : submit_in_chunk_count = $submit_in_chunk_count"
|
||
|
|
|
||
|
|
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"
|
||
|
|
|
||
|
|
# <<<
|
||
|
|
# puts stderr "isodir_return : further chunk_size = $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 ""
|
||
|
|
|
||
|
|
# The local 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 local 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 0
|
||
|
|
|
||
|
|
# 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 "0"
|
||
|
|
|
||
|
|
# Whether .ack_window resp. .yesno_window is already displayed
|
||
|
|
# (>>> Better would be to block user interaction until they are gone)
|
||
|
|
set ack_window_is_active 0
|
||
|
|
set yesno_window_is_active 0
|
||
|
|
|
||
|
|
|
||
|
|
# ------ 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
|
||
|
|
send_marked_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} {
|
||
|
|
inquire_dev
|
||
|
|
return "0"
|
||
|
|
}
|
||
|
|
reset_highest_cmd_sev
|
||
|
|
send_marked_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_marked_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_marked_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_marked_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} {
|
||
|
|
inquire_dev
|
||
|
|
return "0"
|
||
|
|
}
|
||
|
|
reset_highest_cmd_sev
|
||
|
|
send_marked_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
|
||
|
|
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 ""
|
||
|
|
|
||
|
|
clear_sieve
|
||
|
|
send_marked_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
|
||
|
|
update idletasks
|
||
|
|
|
||
|
|
# Command -devices drops all aquired drives
|
||
|
|
refresh_indev
|
||
|
|
refresh_outdev
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
# Refresh the display after some xorriso may have changed the status
|
||
|
|
# Called by the "Refresh state" display 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
|
||
|
|
}
|
||
|
|