/usr/share/openmsx/scripts/_utils.tcl is in openmsx-data 0.10.0-1ubuntu1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 | # Several utility procs for usage in other scripts
# don't export anything, just use it from the namespace,
# because these scripts aren't useful for console users
# and should therefore not be exported to the global
# namespace.
#
# These procs are not specific to anything special,
# they could be useful in any script.
#
# Born to prevent duplication between scripts for common stuff.
namespace eval utils {
proc get_machine_display_name {{machineid ""}} {
if {$machineid eq ""} {
set machineid [machine]
}
if {$machineid eq ""} {
return "<none>"
}
set config_name [${machineid}::machine_info config_name]
return [get_machine_display_name_by_config_name $config_name]
}
proc get_machine_display_name_by_config_name {config_name} {
return [get_display_name_by_config_name $config_name "machines"]
}
proc get_extension_display_name_by_config_name {config_name} {
return [get_display_name_by_config_name $config_name "extensions"]
}
proc get_display_name_by_config_name {config_name type} {
if {[catch {
set names [openmsx_info $type $config_name]
if {$type eq "machines"} {
set keylist [list "manufacturer" "code"]
} elseif {$type eq "extensions"} {
set keylist [list "manufacturer" "code" "name"]
} else {
error "Unsupported type: $type"
}
set arglist [list]
foreach key $keylist {
if [dict exists $names $key] {
set arg [dict get $names $key]
if {$arg ne ""} {
lappend arglist $arg
}
}
}
set result [join $arglist]
# fallback if this didn't give useful results:
if {$result eq ""} {
set result $config_name
}
}]} {
# hmm, XML file probably broken. Fallback:
set $errorInfo
set result "$config_name (CORRUPT)"
}
return $result
}
proc get_machine_time {{machineid ""}} {
if {$machineid eq ""} {
set machineid [machine]
}
set err [catch {set mtime [${machineid}::machine_info time]}]
if {$err} {
return ""
}
return [format_time $mtime]
}
proc format_time {time} {
format "%02d:%02d:%02d" [expr {int($time / 3600)}] [expr {int($time / 60) % 60}] [expr {int($time) % 60}]
}
proc get_ordered_machine_list {} {
lsort -dictionary [list_machines]
}
proc get_random_number {max} {
expr {floor(rand() * $max)}
}
proc clip {min max val} {
expr {($val < $min) ? $min : (($val > $max) ? $max : $val)}
}
# provides.... file completion. Currently has a small issue: it adds a space at
# after a /, which you need to erase to continue completing
proc file_completion {args} {
set result [list]
foreach i [glob -nocomplain -path [lindex $args end] *] {
if {[file isdirectory $i]} {
append i /
}
lappend result $i
}
return $result
}
# Replaces characters that are invalid in file names on the host OS or
# file system by underscores.
if {$::tcl_platform(platform) eq "windows"
|| [string match *-dingux* $::tcl_platform(osVersion)]} {
# Dingux is Linux, but runs on VFAT.
variable _filename_clean_disallowed {[\x00-\x1f\x7f/\\?*:|"<>+\[\]]}
} else {
# UNIX does allow 0x01-0x1f and 0x7f, but we consider them undesirable.
variable _filename_clean_disallowed {[\x00-\x1f\x7f/]}
}
proc filename_clean {path} {
variable _filename_clean_disallowed
return [regsub -all $_filename_clean_disallowed $path _]
}
namespace export get_machine_display_name
namespace export get_machine_display_name_by_config_name
namespace export get_extension_display_name_by_config_name
namespace export get_display_name_by_config_name
namespace export get_machine_time
namespace export format_time
namespace export get_ordered_machine_list
namespace export get_random_number
namespace export clip
namespace export file_completion
namespace export filename_clean
} ;# namespace utils
# Don't import in global namespace, these are only useful in other scripts.
|