@prog ed.muf
1 999 d
1 i
: say me @ swap notify ;
: vchk (field full n -- field 0 / 1)
	(true if field is a prefix of full and field is >=n chars long)
	3 pick strlen > if pop 0 exit then
	( field full )
	dup strlen 3 pick strlen < if pop 0 exit then
	over strlen strcut pop over strcmp if 0 else pop 1 then
;
: getval (obj field -- val)
	"@describe" 3 vchk if desc exit then
	"@drop" 3 vchk if drop exit then
	"@fail" 3 vchk if fail exit then
	"@name" 2 vchk if name exit then
	"@odrop" 3 vchk if odrop exit then
	"@ofail" 3 vchk if ofail exit then
	"@osuccess" 3 vchk if osucc exit then
	"@success" 3 vchk if succ exit then
	getpropstr
;
: setval (obj field val -- )
	swap
	"@describe" 3 vchk if setdesc exit then
	"@drop" 3 vchk if setdrop exit then
	"@fail" 3 vchk if setfail exit then
	"@name" 2 vchk if setname exit then
	"@odrop" 3 vchk if setodrop exit then
	"@ofail" 3 vchk if setofail exit then
	"@osuccess" 3 vchk if setosucc exit then
	"@success" 3 vchk if setsucc exit then
	swap addprop
;
: usage
	"Usage: " trigger @ name strcat " obj/field=XoldXnewXflags" strcat say
	"       X can be any delimiter character; the trailing X can be omitted" say
	"       if the flags are also omitted.  Flags are:" say
	"         g - substitute all occurrences (else just the first)" say
	"         p - print the resulting string" say
	"       Whitespace surrounding the / and = is stripped, but after" say
	"       the first delimiter character, all whitespace is significant." say
;
: stripwhite-lead
	do dup 1 strcut swap " " strcmp if pop exit else swap pop then loop
;
: stripwhite-trail
	dup strlen
	do
		( s len )
		dup 1 < if pop exit then
		over over 1 - strcut " " strcmp if
			pop pop exit
		else
			rot pop swap 1 -
		then
	loop
;
: stripwhite-both
	stripwhite-lead
	stripwhite-trail
;
: main
	dup "" strcmp not if pop usage exit then
	dup "/" instr dup not if 2 mpop usage exit then
	1 - strcut 1 strcut swap pop swap stripwhite-both swap
	( objname field=XoldXnew[Xflags] )
	dup "=" instr dup not if 3 mpop usage exit then
	1 - strcut 1 strcut swap pop swap stripwhite-both swap stripwhite-lead
	( objname field XoldXnew[Xflags] )
	dup strlen 2 < if 3 mpop usage exit then
	1 strcut
	( objname field X oldXnew[Xflags] )
	swap explode
	( objname field [flags] new old 2-or-3  /  other: error )
	dup 2 = if pop "" rot rot 3 then
	( objname field flags new old 3  /  other: error )
	dup 3 = not if 2 + mpop usage exit then pop
	( objname field flags new old )
	swap rot 5 rotate match
	( field old new flags obj )
	dup #-1 dbcmp if 5 mpop "Object not found." say exit then
	dup #-2 dbcmp if 5 mpop "Ambiguous object name." say exit then
	dup #-3 dbcmp if 5 mpop "Can't use home here." say exit then
	me @ wizard? not if over owner me @ dbcmp not if
		5 mpop "Permission denied." say exit
	then then
	( field old new flags obj )
	dup 6 pick getval
	( field old new flags obj oldval )
	3 pick "g" instr if
		4 rotate 5 rotate
		( field flags obj oldval new old )
		subst
		( field flags obj newval )
	else
		5 rotate
		( field new flags obj oldval old )
		over over instr dup if
			( field new flags obj oldval old pos )
			swap strlen
			( field new flags obj oldval pos oldlen )
			rot rot 1 - strcut rot strcut swap pop
			( field new flags obj pre post )
			5 rotate swap strcat strcat
			( field flags obj newval )
		else
			( field new flags obj oldval old 0 )
			pop pop 4 rotate pop
		then
	then
	( field flags obj newval )
	3 pick "p" instr if "New> " over strcat say then
	rot pop rot swap setval
;
.
c
q