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.
 
 
 
 
 
 

5933 lines
182 KiB

#!/usr/bin/wish
#
# xorriso-tcltk
# Copyright (C) 2012 - 2017
# 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
#
# It also may serve as educational frontend to xorriso which tells by
# its message window how to operate xorriso by commands and what it will
# reply.
# 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.9"
# 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]"
if {$preserve_selection == 1} {
memorize_isolist_selection
}
isodir_return "insert_from"
if {$preserve_selection == 1} {
restore_isolist_selection
}
browse_iso_refresh
}
# Copy a file out of the ISO image model to the hard disk filesystem.
# The meta data stem from the ISO model tree. The content data are usually
# read from the input drive.
# Called when button "Extract to disk:" is hit.
#
proc extract_to {} {
global extract_to_adr extract_from_selected extract_underneath
global extract_auto_chmod osirrox_allowed
global isodir_adr isolist_names
if {$osirrox_allowed != 1} {
xorriso_tcltk_errmsg \
"xorriso-tcltk : SORRY : Extraction from ISO to hard disk is already irrevocably banned."
return ""
}
if {[assert_iso_image 1] == 0} {return ""}
if {$extract_to_adr == ""} {
xorriso_tcltk_errmsg \
"xorriso-tcltk : SORRY : You have to set a target address in the hard disk filesystem first"
return ""
}
set sources ""
set selected_ftype ""
set selected_adr ""
if {$extract_from_selected == 1} {
set selected [.isolist curselection]
if {[llength $selected] < 1} {
xorriso_tcltk_errmsg "xorriso-tcltk : SORRY : You must select at least one ISO file as extraction source"
return ""
}
foreach i $selected {
set path [combine_dir_and_name $isodir_adr \
[lindex $isolist_names $i]]
lappend sources $path
}
} else {
set sources [list $isodir_adr]
}
reset_highest_cmd_sev
reset_yesno_to_all
enforce_overwrite_settings "localfs"
set disp_en_mem [set_display_msg 0]
if {$extract_auto_chmod == 1} {
send_loggable_cmd "-osirrox on:sort_lba_on:auto_chmod_on"
} else {
send_loggable_cmd "-osirrox on:sort_lba_off:auto_chmod_off"
}
set_display_msg $disp_en_mem
set multi_source 0
if {[llength $sources] != 1} {set multi_source 1}
foreach i $sources {
if {$extract_underneath == 1} {
set name [file tail $i]
set target [combine_dir_and_name $extract_to_adr $name]
} else {
if {[llength $sources] != 1} {
xorriso_tcltk_errmsg "xorriso-tcltk : SORRY : You must select exactly one ISO file as extraction source"
return ""
}
set target $extract_to_adr
}
if {$i == ""} {
set i "/"
}
set target_ftype [localfs_filetype $target]
set from_is_dir 0
set source_ftype [isofs_filetype $i]
if {[handle_overwriting "localfs" $target $target_ftype \
"isofs" $i $source_ftype $multi_source \
"" "" "merge"] == 0} {
continue
}
send_loggable_cmd \
"-extract [make_text_shellsafe $i] [make_text_shellsafe $target]"
}
browse_tree_populate "localfs"
}
# Send the currently chosen -overwrite settings of the checkbuttons
# "Overwrite ISO files", "Overwrite ISO dirs", "Overwrite hard disk files".
# Called before operations which could overwrite files in ISO model
# or in the hard disk filesystem.
# I.e. any -overwrite command sent via the "Command:" text field will not
# be able to override the checkbuttons.
#
proc enforce_overwrite_settings {which_fs} {
global overwrite_iso_files overwrite_iso_dirs overwrite_disk_files
if {$which_fs == "isofs"} {
if {$overwrite_iso_files == 0} {
set mode "off"
} else {
if {$overwrite_iso_dirs == 0} {
set mode "nondir"
} else {
set mode "on"
}
}
} else {
if {$overwrite_disk_files == 1} {
set mode "on"
} else {