OXYGENHUB
◆ main openmsx / share / scripts / _utils.tcl
4.9 KiB · Tcl · last changed chore(): initial commit 1 month ago source blame history raw
1 
# Several utility procs for usage in other scripts
2 
# don't export anything, just use it from the namespace,
3 
# because these scripts aren't useful for console users
4 
# and should therefore not be exported to the global
5 
# namespace.
6 
#
7 
# These procs are not specific to anything special,
8 
# they could be useful in any script.
9 
#
10 
# Born to prevent duplication between scripts for common stuff.
11
12 
namespace eval utils {
13
14 
proc get_machine_display_name {{machineid ""}} {
15 
	if {$machineid eq ""} {
16 
		set machineid [machine]
17 
	}
18 
	if {$machineid eq ""} {
19 
		return "<none>"
20 
	}
21 
	set config_name [${machineid}::machine_info config_name]
22 
	return [get_machine_display_name_by_config_name $config_name]
23 
}
24
25 
proc get_machine_display_name_by_config_name {config_name} {
26 
	return [get_display_name_by_config_name $config_name "machines"]
27 
}
28
29 
proc get_extension_display_name_by_config_name {config_name} {
30 
	return [get_display_name_by_config_name $config_name "extensions"]
31 
}
32
33 
proc get_display_name_by_config_name {config_name type} {
34 
	if {[catch {
35 
		set names [openmsx_info $type $config_name]
36 
		if {$type eq "machines"} {
37 
			set keylist [list "manufacturer" "code"]
38 
		} elseif {$type eq "extensions"} {
39 
			set keylist [list "manufacturer" "code" "name"]
40 
		} else {
41 
			error "Unsupported type: $type"
42 
		}
43 
		set arglist [list]
44 
		foreach key $keylist {
45 
			if [dict exists $names $key] {
46 
				set arg [dict get $names $key]
47 
				if {$arg ne ""} {
48 
					lappend arglist $arg
49 
				}
50 
			}
51 
		}
52 
		set result [join $arglist]
53 
		# fallback if this didn't give useful results:
54 
		if {$result eq ""} {
55 
			set result $config_name
56 
		}
57 
	}]} {
58 
		# hmm, XML file probably broken. Fallback:
59 
		set result "$config_name (CORRUPT)"
60 
	}
61 
	return $result
62 
}
63
64 
proc get_machine_time {{machineid ""}} {
65 
	if {$machineid eq ""} {
66 
		set machineid [machine]
67 
	}
68 
	set err [catch {set mtime [${machineid}::machine_info time]}]
69 
	if {$err} {
70 
		return ""
71 
	}
72 
	return [format_time $mtime]
73 
}
74
75 
proc format_time {time} {
76 
	format "%02d:%02d:%02d" [expr {int($time / 3600)}] [expr {int($time / 60) % 60}] [expr {int($time) % 60}]
77 
}
78
79 
proc format_time_subseconds {time} {
80 
	format "%02d:%02d.%02d" [expr {int($time / 60)}] [expr {int($time) % 60}] [expr {int(fmod($time,1) * 100)}]
81 
}
82
83 
proc format_time_hours_and_subseconds {time} {
84 
	format "%02d:%02d:%02d.%02d" [expr {int($time / 3600)}] [expr {int($time / 60) % 60}] [expr {int($time) % 60}] [expr {int(fmod($time,1) * 100)}]
85 
}
86
87 
proc get_machine_total_ram {{machineid ""}} {
88 
	if {$machineid eq ""} {
89 
		set machineid [machine]
90 
	}
91 
	set result 0
92 
	foreach device [${machineid}::debug list] {
93 
		if {[${machineid}::debug desc $device] in [list "memory mapper" "ram"]} {
94 
			incr result [${machineid}::debug size $device]
95 
		}
96 
	}
97 
	return $result
98 
}
99
100 
proc get_ordered_machine_list {} {
101 
	lsort -dictionary [list_machines]
102 
}
103
104 
proc get_random_number {max} {
105 
	expr {floor(rand() * $max)}
106 
}
107
108 
proc clip {min max val} {
109 
	expr {($val < $min) ? $min : (($val > $max) ? $max : $val)}
110 
}
111
112 
# provides.... file completion. Currently has a small issue: it adds a space at
113 
# after a /, which you need to erase to continue completing
114 
proc file_completion {args} {
115 
	set result [list]
116 
	foreach i [glob -nocomplain -path [lindex $args end] *] {
117 
		if {[file isdirectory $i]} {
118 
			append i /
119 
		}
120 
		lappend result $i
121 
	}
122 
	return $result
123 
}
124
125 
# Replaces characters that are invalid in file names on the host OS or
126 
# file system by underscores.
127 
if {$::tcl_platform(platform) eq "windows"} {
128 
	variable _filename_clean_disallowed {[\x00-\x1f\x7f/\\?*:|"<>+\[\]]}
129 
} else {
130 
	# UNIX does allow 0x01-0x1f and 0x7f, but we consider them undesirable.
131 
	variable _filename_clean_disallowed {[\x00-\x1f\x7f/]}
132 
}
133 
proc filename_clean {path} {
134 
	variable _filename_clean_disallowed
135 
	return [regsub -all $_filename_clean_disallowed $path _]
136 
}
137
138 
# Gets you a filename with numbers in it to avoid overwriting
139 
# an existing file with the same name. Especially useful for
140 
# cases with automatically generated filenames
141 
proc get_next_numbered_filename {directory prefix suffix} {
142 
	set pattern "${prefix}\[0-9\]\[0-9\]\[0-9\]\[0-9\]${suffix}"
143 
	set files [glob -directory $directory -tails -nocomplain $pattern]
144 
	if {[llength $files] == 0} {
145 
		set num "0001"
146 
	} else {
147 
		set name [lindex [lsort $files] end]
148 
		scan [string range $name [string length $prefix] end] "%4d" n
149 
		if {$n == 9999} {
150 
			error "Can't create new filename"
151 
		}
152 
		set num [format "%04d" [expr {$n + 1}]]
153 
	}
154 
	file join $directory "${prefix}${num}${suffix}"
155 
}
156
157 
namespace export get_machine_display_name
158 
namespace export get_machine_display_name_by_config_name
159 
namespace export get_extension_display_name_by_config_name
160 
namespace export get_display_name_by_config_name
161 
namespace export get_machine_time
162 
namespace export format_time
163 
namespace export get_machine_total_ram
164 
namespace export get_ordered_machine_list
165 
namespace export get_random_number
166 
namespace export clip
167 
namespace export file_completion
168 
namespace export filename_clean
169 
namespace export get_next_numbered_filename
170
171 
} ;# namespace utils
172
173 
# Don't import in global namespace, these are only useful in other scripts.