share/scripts/_cashandler.tcl at main · doomsdayone/openmsx

◆ main openmsx / share / scripts / _cashandler.tcl

10.9 KiB · Tcl · last changed chore(): initial commit 1 month ago source blame history raw

namespace eval cashandler {

set help_text_cas \
{-----------------------------------------------------------
  CAS-file tools 1.0 for openMSX Made By: NYYRIKKI & wouter_
------------------------------------------------------------
Usage:
 casload <file>             | Open CAS-file for load
 cassave <file>             | Open CAS-file for save
 caslist                    | Show loaded CAS-file content
 casrun [<file>] [<number>] | Automatically run program
 caspos <number>            | Select file to load from CAS
 caseject                   | Deactivate CAS-file support
}
set_help_text casload  $help_text_cas
set_help_text cassave  $help_text_cas
set_help_text caslist  $help_text_cas
set_help_text casrun   $help_text_cas
set_help_text caspos   $help_text_cas
set_help_text caseject $help_text_cas
set_tabcompletion_proc casload utils::file_completion
set_tabcompletion_proc cassave utils::file_completion
set_tabcompletion_proc casrun  utils::file_completion

variable fidr ""  ;# file id of opened read  file, "" if not active
variable fidw ""  ;# file id of opened write file, "" if not active
variable bptapion ;# tapion
variable bptapin  ;# tapin
variable bptapoon ;# tapoon
variable bptapout ;# tapout
variable bptapoof ;# tapoof
variable bphread  ;# h.read

variable casheader    [binary format H* "1FA6DEBACC137D74"]
variable casheaderSVI [binary format H* "555555555555555555555555555555557F"]
variable casbios    [dict create r [list 0x00E2 tapion 0x00E5 tapin  0x00E8 tapiof] \
                                 w [list 0x00EB tapoon 0x00EE tapout 0x00F1 tapoof]]
variable casbiosSVI [dict create r [list 0x006A tapion 0x006D tapin  0x0070 tapiof] \
                                 w [list 0x0073 tapoon 0x0076 tapout 0x0079 tapoof]]

proc casload {filename} {
	casopen $filename "r"
	return "Cassette inserted, overriding normal openMSX cassette load routines."
}
proc cassave {filename} {
	casopen $filename "w"
	return "Cassette inserted, overriding normal openMSX cassette save routines."
}
proc caseject {} {
	casclose "r"
	casclose "w"
	return "Cassette ejected, normal openMSX cassette routines in use."
}

proc casopen {filename rw} {
	# Possibly close previous file.
	casclose $rw

	# Open file.
	variable fid${rw}
	set fid${rw} [open $filename $rw]
	fconfigure [set fid${rw}] -translation binary -encoding binary

	# Install BIOS handlers.
	variable casbios
	variable casbiosSVI
	if {[machine_info type] eq "SVI"} {
		set bios $casbiosSVI
	} else {
		set bios $casbios
	}
	foreach {addr func} [dict get $bios $rw] {
		variable bp${func}
		if {[machine_info type] eq "SVI"} {
			set slotspec "3 X X"
		} else {
			set slotspec "0 0"
		}
		set bp${func} [debug set_bp [peek16 $addr "slotted memory"] "\[pc_in_slot {*}${slotspec}\]" [namespace code $func]]
	}
}

proc casclose {rw} {
	# Was active?
	variable fid${rw}
	if {[set fid${rw}] eq ""} return

	# Uninstall BIOS handlers.
	variable casbios
	variable casbiosSVI
	if {[machine_info type] eq "SVI"} {
		set bios $casbiosSVI
	} else {
		set bios $casbios
	}
	foreach {addr func} [dict get $bios $rw] {
		variable bp${func}
		debug remove_bp [set bp${func}]
	}

	if {$rw eq "r"} {
		# In case of read (possibly) also remove bphread.
		variable bphread
		catch {debug remove_bp $bphread} ;# often not set, so catch error
	} else {
	        # In case of write align end of file in order to make combine with other CAS-files easy.
		set align [expr {[tell $fidw] & 7}]
		if {$align} {puts -nonewline $fidw [string repeat \x0 [expr {8 - $align}]]}
	}

	# Close file and deactivate.
	close [set fid${rw}]
	set fid${rw} ""
}

proc tapion {} {
	# TAPION
	# Address  : #00E1
	# Function : Reads the header block after turning the cassette motor on
	# Output   : C-flag set if failed
	# Registers: All
	if {[machine_info type] eq "SVI"} {
		seekheader
	} else {
		reg F [expr {([seekheader] == -1) ? 0x01 : 0x40}] ;# set carry flag if header not found
	}
	ret
}

proc tapin {} {
	# TAPIN
	# Address  : #00E4
	# Function : Read data from the tape
	# Output   : A  - read value
	#           C-flag set if failed
	# Registers: All
	variable fidr
	if {[binary scan [read $fidr 1] cu val]} {
		reg A $val
		reg F 0x40 ;# ok, clear carry flag
	} else {
		reg F 1 ;# end-of-file reached, set carry flag
	}
	ret
}

proc tapiof {} {
        #TAPIOF
        #Address  : #00E7
        #Function : Stops reading from tape
        #Registers: None
	ret
}

proc tapoon {} {
        #TAPOON
        #Address  : #00EA
        #Function : Turns on the cassette motor and writes the header
        #Input    : A  - #00 short header
        #            not #00 long header
        #Output   : C-flag set if failed
        #Registers: All
	if {[catch {
		variable fidw
		variable casheader
		variable casheaderSVI
		if {[machine_info type] eq "SVI"} {
			set header $casheaderSVI
		} else {
			set align [expr {[tell $fidw] & 7}]
			if {$align} {puts -nonewline $fidw [string repeat \x0 [expr {8 - $align}]]}
			set header $casheader
		}
		puts -nonewline $fidw $header
		if {[machine_info type] ne "SVI"} {
			reg F 0x40 ;# ok, clear carry flag
		}
	}]} {
		if {[machine_info type] ne "SVI"} {
			reg F 1 ;# write error, set carry flag
		}
	}
	ret
}

proc tapout {} {
        #TAPOUT
        #Address  : #00ED
        #Function : Writes data on the tape
        #Input    : A  - data to write
        #Output   : C-flag set if failed
        #Registers: All
	if {[catch {
		variable fidw
		puts -nonewline $fidw [binary format c* [reg A]]
		reg F 0x40 ;# all went fine, clear carry flag
	}]} {
		reg F 1 ;# write error, set carry flag
	}
	ret
}

proc tapoof {} {
        #TAPOOF
        #Address  : #00F0
        #Function : Stops writing on the tape
        #Registers: None
	ret
}

proc ret {} {
	reg PC [peek16 [reg SP]]
	reg SP [expr {[reg SP] + 2}]
}

proc seekheader {} {
	variable fidr
	if {[machine_info type] ne "SVI"} {
		# Skip till 8-bytes aligned.
		set align [expr {[tell $fidr] & 7}]
		if {$align} {read $fidr [expr {8 - $align}]}
	}

	# Search header.
	if {[machine_info type] eq "SVI"} {
		while {true} {
			variable casheaderSVI
			set pos [tell $fidr]
			if {[eof $fidr]} {break}
			if {[read $fidr 17] eq $casheaderSVI} {break}
			seek $fidr $pos start
			read $fidr 1
		}

		# Return position of header in cas file, or -1 if not found.
		expr {[eof $fidr] ? -1 : $pos}
	} else {
		variable casheader
		while {![eof $fidr] && [read $fidr 8] ne $casheader} {}

		# Return position of header in cas file, or -1 if not found.
		expr {[eof $fidr] ? -1 : ([tell $fidr] - 8)}
	}
}

proc readheader {} {
	# Read (first) type-id byte.
	variable fidr
	set byte [read $fidr 1]
	if {![binary scan $byte cu val]} {return -1}

	# This must be one of 0xEA 0xD0 0xD3.
	set type [lsearch -exact -integer [list 0xEA 0xD0 0xD3] $val]
	if {$type == -1} {return -1}

	# And it must repeat 9 more times.
	for {set i 0} {$i < 9} {incr i} {
		if {[read $fidr 1] ne $byte} {return -1}
	}
	return $type
}

proc checkactive {} {
	variable fidr
	if {$fidr eq ""} {error "No cas file loaded, use 'casload <filename>'."}
}

proc caslist {} {
	checkactive

	set    result "Position: Type: Name:    Offset:\n"
	append result "--------------------------------\n"

	variable fidr
	set oldpos [tell $fidr]
	seek $fidr 0
	set i 0
	while {![eof $fidr]} {
		set headerpos [seekheader]
		set type [readheader]
		if {$type == -1} continue
		append result [expr {($headerpos < $oldpos) ? "| " : "  "}]
		append result [format %5d [incr i]] " : "
		append result [lindex "TXT BIN BAS" $type] " : "
		append result [read $fidr 6] " : "
		append result $headerpos "\n"
	}
	seek $fidr $oldpos
	return $result
}

proc caspos {{position 1}} {
	checkactive
	lassign [seekpos $position] headerpos type
	return "Cassette header put to offset: $headerpos"
}

# Seek to the start of the n-th header and return both the
# file-offset and the type of this header.
proc seekpos {position} {
	if {![string is integer $position] || ($position <= 0)} {
		error "Expected a strict positive integer, but got $position."
	}

	variable fidr
	seek $fidr 0
	set i 0
	while {$i != $position} {
		set headerpos [seekheader]
		set type [readheader]
		if {$type != -1} {incr i}
		if {[eof $fidr]} {error "No entry $position in this cas file."}
	}
	seek $fidr $headerpos
	list $headerpos $type
}

proc casrun {{filename 1} {position 1}} {
	variable fidr
	variable bphread
	if {[string is integer $filename] && ($fidr ne "")} {
		# First argument is actually a position instead of a filename,
		# only works when there already is a cas file loaded.
		set position $filename
		catch {debug remove_bp $bphread} ;# often not set, so catch error
	} else {
		# Interpret 1st argument as a filename and load it.
		casload $filename
	}
	lassign [seekpos $position] headerpos type

	catch {carta eject}
	catch {cartb eject} ;# there are machines without slot-B
	reset
	set ::power on
	if {[machine_info type] eq "SVI"} {
		set bpaddr 0xfe94
	} else {
		set bpaddr 0xff07
		keymatrixdown 6 1 ;# press SHIFT
	}
	set bphread [debug set_bp ${bpaddr} {} [namespace code "typeload $type"]]
	return ""
}

proc typeload {type} {
	variable bphread
	catch {debug remove_bp $bphread} ;# often not set, so catch error
	if {[machine_info type] eq "SVI"} {
		set keybuf 0xfd8b
		set getpnt 0xfa1c
		set putpnt 0xfa1a
	} else {
		keymatrixup 6 1 ;# release SHIFT
		set keybuf 0xfbf0
		set getpnt 0xf3fa
		set putpnt 0xf3f8
	}

	set cmd [lindex [list "RUN\"CAS:\r" "BLOAD\"CAS:\",R\r" "CLOAD\rRUN\r"] $type]
	debug write_block memory $keybuf $cmd
	poke16 ${getpnt} $keybuf
	poke16 ${putpnt} [expr {$keybuf + [string length $cmd]}]
}

######################################################
proc tapedeck {args} {
	set lastArgIsCas [expr {[string toupper [file extension [lindex $args end]]] eq ".CAS"}]

	if {[llength $args] > 0} {

		variable fidr

		switch [lindex $args 0] {
			eject  {caseject}
			rewind { if {$fidr ne ""} {caspos 1} }
			new    {
					if {$lastArgIsCas} {
						if {[llength $args] != 2} {
							error "Wrong number of arguments for subcommand 'new'."
						}
						cassave [lindex $args end]
						return
					}
				}
		}

		if {$lastArgIsCas} {
			set insert false
			if {[lindex $args 0] == "insert"} {
				if {[llength $args] != 2} {
					error "Wrong number of arguments for subcommand 'insert'."
				} else {
					set insert true
				}
			}
			if {[llength $args] == 1} {
				set insert true
			}
			if {$insert} {
				casload [lindex $args end]
				# for SVI we can't use the trick below, so use typeload
				if {[expr {[machine_info type] eq "SVI" && $::autoruncassettes}]} {
					lassign [seekpos 1] headerpos type
					typeload $type
				}
			}
		}
	}

	if {[machine_info type] ne "SVI" || !$lastArgIsCas} {
		# also insert the file in the normal openMSX cassetteplayer
		# to trigger the behaviour that happens when we do (e.g. autoload)
		# and of course to get normal behaviour for non-CAS files
		return [uplevel 1 [list interp invokehidden {} -global cassetteplayer] $args]
	}
}

######################################################

namespace export casload cassave caslist casrun caspos caseject

} ;# namespace cashandler

namespace import cashandler::*

`/`	Search
`g` `c`	Code
`g` `h`	History
`g` `b`	Bookmarks
`g` `t`	Trust
`y`	Permalink to this state (files and trees)
`?`	This sheet

e8555c89 Andy McCall 1 month ago	1	namespace eval cashandler {
	2
	3	set help_text_cas \
	4	{-----------------------------------------------------------
	5	CAS-file tools 1.0 for openMSX Made By: NYYRIKKI & wouter_
	6	------------------------------------------------------------
	7	Usage:
	8	casload <file> \| Open CAS-file for load
	9	cassave <file> \| Open CAS-file for save
	10	caslist \| Show loaded CAS-file content
	11	casrun [<file>] [<number>] \| Automatically run program
	12	caspos <number> \| Select file to load from CAS
	13	caseject \| Deactivate CAS-file support
	14	}
	15	set_help_text casload $help_text_cas
	16	set_help_text cassave $help_text_cas
	17	set_help_text caslist $help_text_cas
	18	set_help_text casrun $help_text_cas
	19	set_help_text caspos $help_text_cas
	20	set_help_text caseject $help_text_cas
	21	set_tabcompletion_proc casload utils::file_completion
	22	set_tabcompletion_proc cassave utils::file_completion
	23	set_tabcompletion_proc casrun utils::file_completion
	24
	25	variable fidr "" ;# file id of opened read file, "" if not active
	26	variable fidw "" ;# file id of opened write file, "" if not active
	27	variable bptapion ;# tapion
	28	variable bptapin ;# tapin
	29	variable bptapoon ;# tapoon
	30	variable bptapout ;# tapout
	31	variable bptapoof ;# tapoof
	32	variable bphread ;# h.read
	33
	34	variable casheader [binary format H* "1FA6DEBACC137D74"]
	35	variable casheaderSVI [binary format H* "555555555555555555555555555555557F"]
	36	variable casbios [dict create r [list 0x00E2 tapion 0x00E5 tapin 0x00E8 tapiof] \
	37	w [list 0x00EB tapoon 0x00EE tapout 0x00F1 tapoof]]
	38	variable casbiosSVI [dict create r [list 0x006A tapion 0x006D tapin 0x0070 tapiof] \
	39	w [list 0x0073 tapoon 0x0076 tapout 0x0079 tapoof]]
	40
	41	proc casload {filename} {
	42	casopen $filename "r"
	43	return "Cassette inserted, overriding normal openMSX cassette load routines."
	44	}
	45	proc cassave {filename} {
	46	casopen $filename "w"
	47	return "Cassette inserted, overriding normal openMSX cassette save routines."
	48	}
	49	proc caseject {} {
	50	casclose "r"
	51	casclose "w"
	52	return "Cassette ejected, normal openMSX cassette routines in use."
	53	}
	54
	55	proc casopen {filename rw} {
	56	# Possibly close previous file.
	57	casclose $rw
	58
	59	# Open file.
	60	variable fid${rw}
	61	set fid${rw} [open $filename $rw]
	62	fconfigure [set fid${rw}] -translation binary -encoding binary
	63
	64	# Install BIOS handlers.
65	variable casbios
66	variable casbiosSVI
67	if {[machine_info type] eq "SVI"} {
68	set bios $casbiosSVI
69	} else {
70	set bios $casbios
71	}
72	foreach {addr func} [dict get $bios $rw] {
73	variable bp${func}
74	if {[machine_info type] eq "SVI"} {
75	set slotspec "3 X X"
76	} else {
77	set slotspec "0 0"
78	}
79	set bp${func} [debug set_bp [peek16 $addr "slotted memory"] "\[pc_in_slot {*}${slotspec}\]" [namespace code $func]]
80	}
81	}
82
83	proc casclose {rw} {
84	# Was active?
85	variable fid${rw}
86	if {[set fid${rw}] eq ""} return
87
88	# Uninstall BIOS handlers.
89	variable casbios
90	variable casbiosSVI
91	if {[machine_info type] eq "SVI"} {
92	set bios $casbiosSVI
93	} else {
94	set bios $casbios
95	}
96	foreach {addr func} [dict get $bios $rw] {
97	variable bp${func}
98	debug remove_bp [set bp${func}]
99	}
100
101	if {$rw eq "r"} {
102	# In case of read (possibly) also remove bphread.
103	variable bphread
104	catch {debug remove_bp $bphread} ;# often not set, so catch error
105	} else {
106	# In case of write align end of file in order to make combine with other CAS-files easy.
107	set align [expr {[tell $fidw] & 7}]
108	if {$align} {puts -nonewline $fidw [string repeat \x0 [expr {8 - $align}]]}
109	}
110
111	# Close file and deactivate.
112	close [set fid${rw}]
113	set fid${rw} ""
114	}
115
116	proc tapion {} {
117	# TAPION
118	# Address : #00E1
119	# Function : Reads the header block after turning the cassette motor on
120	# Output : C-flag set if failed
121	# Registers: All
122	if {[machine_info type] eq "SVI"} {
123	seekheader
124	} else {
125	reg F [expr {([seekheader] == -1) ? 0x01 : 0x40}] ;# set carry flag if header not found
126	}
127	ret
128	}
129
130	proc tapin {} {
131	# TAPIN
132	# Address : #00E4
133	# Function : Read data from the tape
134	# Output : A - read value
135	# C-flag set if failed
136	# Registers: All
137	variable fidr
138	if {[binary scan [read $fidr 1] cu val]} {
139	reg A $val
140	reg F 0x40 ;# ok, clear carry flag
141	} else {
142	reg F 1 ;# end-of-file reached, set carry flag
143	}
144	ret
145	}
146
147	proc tapiof {} {
148	#TAPIOF
149	#Address : #00E7
150	#Function : Stops reading from tape
151	#Registers: None
152	ret
153	}
154
155	proc tapoon {} {
156	#TAPOON
157	#Address : #00EA
158	#Function : Turns on the cassette motor and writes the header
159	#Input : A - #00 short header
160	# not #00 long header
161	#Output : C-flag set if failed
162	#Registers: All
163	if {[catch {
164	variable fidw
165	variable casheader
166	variable casheaderSVI
167	if {[machine_info type] eq "SVI"} {
168	set header $casheaderSVI
169	} else {
170	set align [expr {[tell $fidw] & 7}]
171	if {$align} {puts -nonewline $fidw [string repeat \x0 [expr {8 - $align}]]}
172	set header $casheader
173	}
174	puts -nonewline $fidw $header
175	if {[machine_info type] ne "SVI"} {
176	reg F 0x40 ;# ok, clear carry flag
177	}
178	}]} {
179	if {[machine_info type] ne "SVI"} {
180	reg F 1 ;# write error, set carry flag
181	}
182	}
183	ret
184	}
185
186	proc tapout {} {
187	#TAPOUT
188	#Address : #00ED
189	#Function : Writes data on the tape
190	#Input : A - data to write
191	#Output : C-flag set if failed
192	#Registers: All
193	if {[catch {
194	variable fidw
195	puts -nonewline $fidw [binary format c* [reg A]]
196	reg F 0x40 ;# all went fine, clear carry flag
197	}]} {
198	reg F 1 ;# write error, set carry flag
199	}
200	ret
201	}
202
203	proc tapoof {} {
204	#TAPOOF
205	#Address : #00F0
206	#Function : Stops writing on the tape
207	#Registers: None
208	ret
209	}
210
211	proc ret {} {
212	reg PC [peek16 [reg SP]]
213	reg SP [expr {[reg SP] + 2}]
214	}
215
216	proc seekheader {} {
217	variable fidr
218	if {[machine_info type] ne "SVI"} {
219	# Skip till 8-bytes aligned.
220	set align [expr {[tell $fidr] & 7}]
221	if {$align} {read $fidr [expr {8 - $align}]}
222	}
223
224	# Search header.
225	if {[machine_info type] eq "SVI"} {
226	while {true} {
227	variable casheaderSVI
228	set pos [tell $fidr]
229	if {[eof $fidr]} {break}
230	if {[read $fidr 17] eq $casheaderSVI} {break}
231	seek $fidr $pos start
232	read $fidr 1
233	}
234
235	# Return position of header in cas file, or -1 if not found.
236	expr {[eof $fidr] ? -1 : $pos}
237	} else {
238	variable casheader
239	while {![eof $fidr] && [read $fidr 8] ne $casheader} {}
240
241	# Return position of header in cas file, or -1 if not found.
242	expr {[eof $fidr] ? -1 : ([tell $fidr] - 8)}
243	}
244	}
245
246	proc readheader {} {
247	# Read (first) type-id byte.
248	variable fidr
249	set byte [read $fidr 1]
250	if {![binary scan $byte cu val]} {return -1}
251
252	# This must be one of 0xEA 0xD0 0xD3.
253	set type [lsearch -exact -integer [list 0xEA 0xD0 0xD3] $val]
254	if {$type == -1} {return -1}
255
256	# And it must repeat 9 more times.
257	for {set i 0} {$i < 9} {incr i} {
258	if {[read $fidr 1] ne $byte} {return -1}
259	}
260	return $type
261	}
262
263	proc checkactive {} {
264	variable fidr
265	if {$fidr eq ""} {error "No cas file loaded, use 'casload <filename>'."}
266	}
267
268	proc caslist {} {
269	checkactive
270
271	set result "Position: Type: Name: Offset:\n"
272	append result "--------------------------------\n"
273
274	variable fidr
275	set oldpos [tell $fidr]
276	seek $fidr 0
277	set i 0
278	while {![eof $fidr]} {
279	set headerpos [seekheader]
280	set type [readheader]
281	if {$type == -1} continue
282	append result [expr {($headerpos < $oldpos) ? "\| " : " "}]
283	append result [format %5d [incr i]] " : "
284	append result [lindex "TXT BIN BAS" $type] " : "
285	append result [read $fidr 6] " : "
286	append result $headerpos "\n"
287	}
288	seek $fidr $oldpos
289	return $result
290	}
291
292	proc caspos {{position 1}} {
293	checkactive
294	lassign [seekpos $position] headerpos type
295	return "Cassette header put to offset: $headerpos"
296	}
297
298	# Seek to the start of the n-th header and return both the
299	# file-offset and the type of this header.
300	proc seekpos {position} {
301	if {![string is integer $position] \|\| ($position <= 0)} {
302	error "Expected a strict positive integer, but got $position."
303	}
304
305	variable fidr
306	seek $fidr 0
307	set i 0
308	while {$i != $position} {
309	set headerpos [seekheader]
310	set type [readheader]
311	if {$type != -1} {incr i}
312	if {[eof $fidr]} {error "No entry $position in this cas file."}
313	}
314	seek $fidr $headerpos
315	list $headerpos $type
316	}
317
318	proc casrun {{filename 1} {position 1}} {
319	variable fidr
320	variable bphread
321	if {[string is integer $filename] && ($fidr ne "")} {
322	# First argument is actually a position instead of a filename,
323	# only works when there already is a cas file loaded.
324	set position $filename
325	catch {debug remove_bp $bphread} ;# often not set, so catch error
326	} else {
327	# Interpret 1st argument as a filename and load it.
328	casload $filename
329	}
330	lassign [seekpos $position] headerpos type
331
332	catch {carta eject}
333	catch {cartb eject} ;# there are machines without slot-B
334	reset
335	set ::power on
336	if {[machine_info type] eq "SVI"} {
337	set bpaddr 0xfe94
338	} else {
339	set bpaddr 0xff07
340	keymatrixdown 6 1 ;# press SHIFT
341	}
342	set bphread [debug set_bp ${bpaddr} {} [namespace code "typeload $type"]]
343	return ""
344	}
345
346	proc typeload {type} {
347	variable bphread
348	catch {debug remove_bp $bphread} ;# often not set, so catch error
349	if {[machine_info type] eq "SVI"} {
350	set keybuf 0xfd8b
351	set getpnt 0xfa1c
352	set putpnt 0xfa1a
353	} else {
354	keymatrixup 6 1 ;# release SHIFT
355	set keybuf 0xfbf0
356	set getpnt 0xf3fa
357	set putpnt 0xf3f8
358	}
359
360	set cmd [lindex [list "RUN\"CAS:\r" "BLOAD\"CAS:\",R\r" "CLOAD\rRUN\r"] $type]
361	debug write_block memory $keybuf $cmd
362	poke16 ${getpnt} $keybuf
363	poke16 ${putpnt} [expr {$keybuf + [string length $cmd]}]
364	}
365
366	######################################################
367	proc tapedeck {args} {
368	set lastArgIsCas [expr {[string toupper [file extension [lindex $args end]]] eq ".CAS"}]
369
370	if {[llength $args] > 0} {
371
372	variable fidr
373
374	switch [lindex $args 0] {
375	eject {caseject}
376	rewind { if {$fidr ne ""} {caspos 1} }
377	new {
378	if {$lastArgIsCas} {
379	if {[llength $args] != 2} {
380	error "Wrong number of arguments for subcommand 'new'."
381	}
382	cassave [lindex $args end]
383	return
384	}
385	}
386	}
387
388	if {$lastArgIsCas} {
389	set insert false
390	if {[lindex $args 0] == "insert"} {
391	if {[llength $args] != 2} {
392	error "Wrong number of arguments for subcommand 'insert'."
393	} else {
394	set insert true
395	}
396	}
397	if {[llength $args] == 1} {
398	set insert true
399	}
400	if {$insert} {
401	casload [lindex $args end]
402	# for SVI we can't use the trick below, so use typeload
403	if {[expr {[machine_info type] eq "SVI" && $::autoruncassettes}]} {
404	lassign [seekpos 1] headerpos type
405	typeload $type
406	}
407	}
408	}
409	}
410
411	if {[machine_info type] ne "SVI" \|\| !$lastArgIsCas} {
412	# also insert the file in the normal openMSX cassetteplayer
413	# to trigger the behaviour that happens when we do (e.g. autoload)
414	# and of course to get normal behaviour for non-CAS files
415	return [uplevel 1 [list interp invokehidden {} -global cassetteplayer] $args]
416	}
417	}
418
419	######################################################
420
421	namespace export casload cassave caslist casrun caspos caseject
422
423	} ;# namespace cashandler
424
425	namespace import cashandler::*

Keyboard