OXYGENHUB
◆ main openmsx / share / init.tcl
7.3 KiB · Tcl · last changed chore(): initial commit 1 month ago source blame history raw
1 
# evaluate in internal openmsx namespace
2 
namespace eval openmsx {
3
4 
variable init_tcl_executed false
5 
variable tabcompletion_proc_sensitive
6 
variable tabcompletion_proc_insensitive
7 
variable help_text
8 
variable help_proc
9 
variable lazy [dict create]
10
11 
# Only execute this script once. Below we source other Tcl script,
12 
# so this makes sure we don't get in an infinite loop.
13 
if {$init_tcl_executed} return
14 
set init_tcl_executed true
15
16 
# Debug pints (disabled by default).
17 
proc dbg {msg} {
18 
	#puts stderr $msg
19 
}
20
21 
# Helpers to handle on-demand (lazy) loading of Tcl scripts
22
23 
# Register 'script' to be loaded on-demand when one of the proc names in
24 
# 'procs' is about to be executed. See also 'lazy.tcl'.
25 
proc register_lazy {script procs} {
26 
	variable lazy
27 
	dict set lazy $script $procs
28 
}
29
30 
# Lookup the script associated with the given proc name. If found that script
31 
# is executed (and the script+proc-names are removed from the list of
32 
# yet-to-be-executed lazy scripts).
33 
proc lazy_handler {name} {
34 
	variable lazy
35 
	# Registered names can be fully qualified (e.g. 'cheat_finder::start'),
36 
	# so match on both the qualified name and the bare proc name.
37 
	set full [string trimleft $name :]
38 
	set tail [namespace tail $name]
39 
	dict for {script procs} $lazy {
40 
		if {($full ni $procs) && ($tail ni $procs)} continue
41 
		dict unset lazy $script
42 
		dbg "start executing script $script (via lazy_handler)"
43 
		if {[catch {namespace eval :: [list source [data_file scripts/$script]]}]} {
44 
			puts stderr "Error while (lazily) loading Tcl script: $script\n$::errorInfo"
45 
			error $::errorInfo
46 
		}
47 
		dbg "done executing script $script"
48 
		return true
49 
	}
50 
	return false
51 
}
52
53 
# Execute all not yet executed lazy-scripts. ATM this is (only) required for
54 
# the 'about' command which has to search through the help text of all the
55 
# scripts.
56 
proc lazy_execute_all {} {
57 
	variable lazy
58 
	# cannot simply iterate because the 'source' command below might
59 
	# trigger a load of a script later in the collection
60 
	while {[dict size $lazy] != 0} {
61 
		set script [lindex [dict keys $lazy] 0]
62 
		dict unset lazy $script
63 
		dbg "start executing script $script (via lazy_execute_all)"
64 
		if {[catch {namespace eval :: [list source [data_file scripts/$script]]}]} {
65 
			puts stderr "Error while (lazily) loading Tcl script: $script\n$::errorInfo"
66 
			error $::errorInfo
67 
		}
68 
		dbg "done executing script $script"
69 
	}
70 
}
71
72 
# Return a list of all command names. This includes:
73 
#   builtin Tcl commands,
74 
#   procs defined in Tcl scripts,
75 
#   procs from not yet loaded lazy-scripts (see register_lazy).
76 
# This helper proc is used for tab-completion in the openMSX console.
77 
proc all_command_names {} {
78 
	variable lazy
79 
	set result [info commands]
80 
	foreach procs [dict values $lazy] {
81 
		lappend result {*}$procs
82 
	}
83 
	# only one level deep, good enough for machineN::*
84 
	foreach ns [namespace children ::] {
85 
		lappend result {*}[info commands ${ns}::*]
86 
	}
87 
	return $result
88 
}
89
90 
# Returns a list of Tcl commands that provide extra help (text or proc).
91 
# Note: there may also be commands implemented in c++ which provide help.
92 
proc all_command_names_with_help {} {
93 
	lazy_execute_all
94 
	set result [array names ::openmsx::help_text]
95 
	lappend result {*}[array names ::openmsx::help_proc]
96 
	return $result
97 
}
98
99 
# Is the given name a name of a proc, possibly a name defined in a not-yet
100 
# loaded script. This helper proc is used for syntax-highlighting in the
101 
# openMSX console.
102 
proc is_command_name {name} {
103 
	if {[info commands ::$name] ne ""} {return 1}
104 
	expr {[lsearch -exact [all_command_names] [namespace tail $name]] != -1}
105 
}
106
107 
# Override the builtin Tcl proc 'unknown'. This is called when the Tcl
108 
# interpreter is about to execute an undefined command.
109 
proc ::unknown {args} {
110 
	#puts stderr "unknown: $args"
111 
	set name [lindex $args 0]
112 
	if {[openmsx::lazy_handler $name]} {
113 
		return [uplevel 1 $args]
114 
	}
115 
	return -code error "invalid command name \"$name\""
116 
}
117
118
119 
# internal proc to make help function available to Tcl procs
120 
proc help {args} {
121 
	variable help_text
122 
	variable help_proc
123
124 
	set command [lindex $args 0]
125 
	lazy_handler $command
126 
	if {[info exists help_proc($command)]} {
127 
		return [namespace eval :: $help_proc($command) $args]
128 
	} elseif {[info exists help_text($command)]} {
129 
		return $help_text($command)
130 
	} elseif {[info commands $command] ne ""} {
131 
		error "No help for command: $command"
132 
	} else {
133 
		error "Unknown command: $command"
134 
	}
135 
}
136 
proc set_help_text {command help} {
137 
	variable help_text
138 
	set help_text($command) $help
139 
}
140 
set_help_text set_help_text \
141 
{Associate a help-text with a Tcl proc. This is normally only used in Tcl scripts.}
142
143 
proc set_help_proc {command procname} {
144 
	variable help_proc
145 
	set help_proc($command) $procname
146 
}
147 
set_help_text set_help_proc \
148 
{Associate a help-proc with a Tcl proc. This is normally only used in Tcl scripts.}
149
150 
# internal proc to make tabcompletion available to Tcl procs
151 
proc tabcompletion {args} {
152 
	variable tabcompletion_proc_sensitive
153 
	variable tabcompletion_proc_insensitive
154
155 
	set command [lindex $args 0]
156 
	lazy_handler $command
157 
	set result ""
158 
	if {[info exists tabcompletion_proc_sensitive($command)]} {
159 
		set result [namespace eval :: $tabcompletion_proc_sensitive($command) $args]
160 
		lappend result true
161 
	} elseif {[info exists tabcompletion_proc_insensitive($command)]} {
162 
		set result [namespace eval :: $tabcompletion_proc_insensitive($command) $args]
163 
		lappend result false
164 
	}
165 
	return $result
166 
}
167 
proc set_tabcompletion_proc {command proc {case_sensitive true}} {
168 
	variable tabcompletion_proc_sensitive
169 
	variable tabcompletion_proc_insensitive
170 
	if {$case_sensitive} {
171 
		set tabcompletion_proc_sensitive($command) $proc
172 
	} else {
173 
		set tabcompletion_proc_insensitive($command) $proc
174 
	}
175 
}
176 
set_help_text set_tabcompletion_proc \
177 
{Provide a way to do tab-completion for a certain Tcl proc. For details look at the numerous examples in the share/scripts directory. This is normally only used in Tcl scripts.}
178
179 
set_help_text data_file \
180 
"Resolve data file. First try user directory, if the file doesn't exist
181 
there try the system directory."
182 
proc data_file { file } {
183 
	set user_file $::env(OPENMSX_USER_DATA)/$file
184 
	if {[file exists $user_file]} { return $user_file }
185 
	return $::env(OPENMSX_SYSTEM_DATA)/$file
186 
}
187
188 
namespace export register_lazy
189 
namespace export set_help_text
190 
namespace export set_help_proc
191 
namespace export set_tabcompletion_proc
192 
namespace export data_file
193
194 
} ;# namespace openmsx
195
196 
namespace import openmsx::*
197
198 
namespace eval openmsx {
199
200 
# Source all .tcl files in user and system scripts directory. Prefer
201 
# the version in the user directory in case a script exists in both
202 
set user_scripts [glob -dir $::env(OPENMSX_USER_DATA)/scripts -tails -nocomplain *.tcl]
203 
set system_scripts [glob -dir $::env(OPENMSX_SYSTEM_DATA)/scripts -tails -nocomplain *.tcl]
204 
set profile_list [list]
205 
foreach script [lsort -unique [concat $user_scripts $system_scripts]] {
206 
	# Skip scripts that start with a '_' character. (By convention) those
207 
	# are loaded on-demand (see 'lazy.tcl').
208 
	if {[string index $script 0] eq "_"} continue
209 
	set script [data_file scripts/$script]
210 
	set t1 [openmsx_info realtime]
211 
	dbg "start executing script $script (via startup sequence)"
212 
	if {[catch {namespace eval :: [list source $script]}]} {
213 
		puts stderr "Error while executing $script\n$errorInfo"
214 
	}
215 
	dbg "done executing script $script"
216 
	set t2 [openmsx_info realtime]
217 
	lappend profile_list [list [expr {int(1000000 * ($t2 - $t1))}] $script]
218 
}
219 
if 0 {
220 
	foreach e [lsort -integer -index 0 $profile_list] { puts stderr $e }
221 
}
222
223 
} ;# namespace openmsx