# Pre-process a simple form.
# The form has three fields:
#  name is a text field which should contain two alphabetic words.
#  job is a text field which may be anything
#  age is a text field which should be an integer 0 < age <= 100
# The checks are performed on-the-fly

proc HMreset_form {args} {
    global age agewin

    puts "HMreset_form $args"

    # Reset our internal state to be consistent with the form's state
    set age [$agewin get]
}

proc HMend_form {args} {
    puts "HMendform $args"
}

proc terminate {} {
    global namewin agewin

    # Safe-Tk should do this automatically
    bind $namewin <KeyPress> {}
    bind $agewin <KeyPress> {}
}

proc HMsubmit_form {method query} {
    global namewin agewin
    puts "HMsubmit_form $method $query"

    # Check name field
    if {$namewin == {}} {
	puts "no item for name"
    } else {
	set name [$namewin get]
	if {[llength $name] < 2} {
	    tk_dialog .errmsg "Form Entry Error" "You must specify both names" {} 0 "OK"
	    # Flash the offending field
	    flash $namewin
	    error "bad form input"
	} elseif {[llength $name] > 2} {
	    tk_dialog .errmsg "Form Entry Error" "You may only specify first name and surname" {} 0 "OK"
	    # Flash the offending field
	    flash $namewin
	    error "bad form input"
	} elseif {[regexp {[A-Z][a-z]+ [A-Z][a-z]+} $name] != 1} {
	    tk_dialog .errmsg "Form Entry Error" "You must specify a proper name" {} 0 "OK"
	    # Flash the offending field
	    flash $namewin
	    error "bad form input"
	}
    }

    # Check age field
    if {$agewin == {}} {
	puts "no item for age"
    } else {
	set age [$agewin get]
	# Should check that (local) age is equal to the global age variable
	if {[catch {expr abs(int($age)) == $age} same]} {
	    tk_dialog .errmsg "Form Entry Error" "You must specify a number for your age" {} 0 "OK"
	    # Flash the offending field
	    flash $agewin
	    error "bad form input"
	} elseif {!$same || $age > 100} {
	    tk_dialog .errmsg "Form Entry Error" "How can you be $age years old?" {} 0 "OK"
	    # Flash the offending field
	    flash $agewin
	    error "bad form input"
	}
    }

    # If we get to here then everything is OK
    return $query
}

proc flash {item} {
    global flashcnt flashid flashprevbg

    if {[info exists flashid($item)]} {
	# Stop previous call to flash
	after cancel $flashid($item)
    }

    set flashcnt($item) 3
    set flashprevbg($item) [$item cget -background]
    set flashid($item) [after 250 do_flash on $item]
}

proc do_flash {toggle item} {
    global flashcnt flashid flashprevbg

    if {$toggle} {
	[applet embedwindow] see [[applet embedwindow] index $item] ;# Make sure flashing can be seen
	$item configure -background orange
	incr flashcnt($item) -1
	set flashid($item) [after 250 do_flash off $item]
    } else {
	$item configure -background $flashprevbg($item)
	if {$flashcnt($item)} {
	    set flashid($item) [after 250 do_flash on $item]
	}
    }
}

set items {}
set namewin {}
set agewin {}

# It would be nicer to arrange the widget bindings to simply "break" if
# an illegal character is typed, but a bug in Safe-Tk requires these workarounds

proc HMapplet_item {type name item} {
    global items namewin agewin age
    puts "HMapplet_item type \"$type\" name \"$name\" item \"$item\""
    lappend items [list $type $name $item]
    display_items

    # Find the interesting widgets
    if {$name == "name"} {
	set namewin $item
	bind $item <KeyPress> {name_filter %W %K}
	# Move this binding to after the Class binding
	bindtags $item [concat [lrange [bindtags $item] 1 end] " " [lindex [bindtags $item] 0]]
    } elseif {$name == "age"} {
	set agewin $item
	bind $item <KeyPress> {age_filter %W %K}
	# Move this binding to after the Class binding
	bindtags $item [concat [lrange [bindtags $item] 1 end] " " [lindex [bindtags $item] 0]]
	set age [$item get]
	if {$age == {}} {set age 0}
    }
}

# Names should only allow alphabetic characters and only one space
proc name_filter {win keysym} {
    set name [$win get]
    if {[llength $name] > 2} {
	# Remove the offending extra words
	$win delete 0 end
	$win insert end [lrange $name 0 1]
	bell
    } elseif {[regexp -indices {([^A-Za-z ])} $name all bogus]} {
	$win delete [lindex $bogus 0] end
	bell
    }
}

# Age should be an integer between 0 and 100
# We should be smarter/more lenient and delete only the offending part
proc age_filter {win keysym} {
    set age [$win get]
    if {[catch {expr abs(int($age)) == $age} same]} {
	$win delete 0 end; bell
    } elseif {!$same || $age > 100} {
	$win delete 0 end; bell
    }
}

proc display_items {} {
    global items

    destroy .f.items
    frame .f.items
    pack .f.items -side top
    set cnt 0
    foreach i $items {
	label .f.items.$cnt -text "[lindex $i 0] [lindex $i 1] [lindex $i 2]"
	pack .f.items.$cnt
	incr cnt
    }
}

frame .f
label .f.lab -text "Form has items:"
frame .f.items
pack .f.lab .f.items -side top
pack .f
