You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
5929 lines
182 KiB
5929 lines
182 KiB
#!/usr/bin/wish |
|
# |
|
# xorriso-tcltk |
|
# Copyright (C) 2012 - 2016 |
|
# 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.4.7" |
|
|
|
# Minimum version of xorriso to be used as backend process. |
|
# Older versions of xorriso do not offer commands -msg_op and -launch_frontend |
|
set min_xorriso_version "1.2.6" |
|
|
|
|
|
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 essential xorriso" |
|
puts stderr " commands and enable this logging." |
|
puts stderr " The log lines will be appended. Path \"-\" means stderr." |
|
puts stderr " --script_log_all_commands" |
|
puts stderr " With logging of commands log non-essential commands too." |
|
puts stderr " --use_command_move" |
|
puts stderr " Use xorriso command -move for the \"Move to:\" button" |
|
puts stderr " if xorriso version is >= 1.2.8" |
|
puts stderr " --use_command_mv" |
|
puts stderr " Use xorriso command -mv for the \"Move to:\" button." |
|
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 (or 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" |
|
|
|
# Whether to use command -move rather than -mv. Possible since xorriso-1.2.8. |
|
set use_command_move 1 |
|
|
|
# Whether to enable -hardlinks mode "on". Too slow before xorriso-1.3.0. |
|
set use_command_hardlinks_on 1 |
|
|
|
|
|
# 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 |
|
|
|
# Whether to log all commands if cmd_logging_mode is 1: 0=off , 1=on |
|
set cmd_logging_all 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 |
|
log_command $cmd 0 |
|
|
|
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 1 |
|
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 use_command_move use_command_hardlinks_on |
|
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 |
|
} |
|
if {$xorriso_version < "1.2.8"} { |
|
set use_command_move 0 |
|
} |
|
if {$xorriso_version < "1.3.0"} { |
|
set use_command_hardlinks_on 0 |
|
} |
|
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 {} { |
|
global use_command_hardlinks_on |
|
|
|
set cmd "-for_backup" |
|
|
|
# Before xorriso-1.3.0 there is a performance problem with -hardlinks "on" |
|
# and image manipulations before xorriso-1.3.0. |
|
if {$use_command_hardlinks_on == 0} { |
|
set cmd "$cmd -hardlinks off" |
|
} else { |
|
set cmd "$cmd -hardlinks on" |
|
} |
|
|
|
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 acquired 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 acquired 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 or 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 use_command_move |
|
|
|
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" && $use_command_move == 0} { |
|
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 \ |
|
"" "" "replace"] == "0"} { |
|
if {$multi_source == 0} { return "" } |
|
continue |
|
} |
|
if {$use_command_move == 0} { |
|
send_loggable_cmd \ |
|
"-mv [make_text_shellsafe $name] [make_text_shellsafe $target] --" |
|
} else { |
|
send_loggable_cmd \ |
|
"-move [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 acquired 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_loggable_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 dir_action} { |
|
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 {$dir_action == "replace"} { |
|
if {$overwrite_iso_dirs != 1} { |
|
xorriso_tcltk_errmsg "xorriso-tcltk : SORRY : You would have to enable \"Overwrite $overwrite_fs dirs\" for\n[make_text_shellsafe $target]" |
|
return "0" |
|
} |
|
if {[$what_window \ |
|
"Really replace existing $to_fs directory\n\n[make_text_shellsafe $target]\n\nby $from_fs directory\n[make_text_shellsafe $source]\n?"] \ |
|
!= 1} { return "0" } |
|
return "1" |
|
} |
|
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 "merge"] == "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]" |