# tkfprops.tcl --
#
#	Implements the "TK" standard file properties dialog box.
#
# RCS: @(#) $Id: tkfprops.tcl,v 1.1.2.3 2004/11/23 19:35:23 matt Exp $
#
#
#----------------------------------------------------------------------
#
#		      F I L E   P R O P E R T I E S   D I A L O G
#
#----------------------------------------------------------------------

# This procedure returns the full path name of the file, whether it has been changed or it hasn't 
proc tk_fileProperties {file args} {
    ::tk::dialog::fprops::tkFProps $file $args
}

namespace eval ::tk::dialog {}
namespace eval ::tk::dialog::fprops {}

# ::tk::dialog::fprops::tk_fileProperties --
#
#	Implements the TK file properties dialog.

proc ::tk::dialog::fprops::tkFProps {file argList} {
    if {![file exists $file] && [file type $file] != "link"} return
    for {set i 1} {[winfo exists [set w .__tk_fprops$i]]} {incr i} {}
    set dataName [string trimleft $w .]
    upvar ::tk::dialog::fprops::$dataName data
    ::tk::dialog::fprops::Config $dataName $file $argList
    if {[string equal $data(-parent) .]} {
        set w .$dataName
    } else {
        set w $data(-parent).$dataName
    }
    return [::tk::dialog::fprops::Create $w]
}

proc ::tk::dialog::fprops::Config {dataName file argList} {
    upvar ::tk::dialog::fprops::$dataName data
    global tcl_platform

    # 1: the configuration specs
    #
    set specs {
	{-icons "" "" ""}
	{-parent "" "" "."}
    }
    if {[file pathtype $file] != "absolute"} {
	set data(file) [file join [pwd] $file]
    } else {
	set data(file) $file
    }

    set data(top) 0
    # This ensures it must have only one "/" at the end
    set top "[string trimright $data(file) /]/"
    if {$tcl_platform(platform) == "windows"} {
	if {[lsearch -regexp [file volume] "***:(?i)^$top$"] >= 0} {
	    set data(file) $top
	    set data(top) 1
	}
    } elseif {$tcl_platform(platform) == "unix"} {
	if {$top == "/"} {
	    set data(file) $top
	    set data(top) 1
	}
    }	

    # 2: parse the arguments
    #
    tclParseConfigSpec ::tk::dialog::fprops::$dataName $specs "" $argList
}

proc ::tk::dialog::fprops::Create {w} {
    set dataName [lindex [split $w .] end]
    upvar ::tk::dialog::fprops::$dataName data
    set var ::tk::dialog::fprops::$dataName
    variable ::tk::Priv
    global tcl_platform

    toplevel $w -class TkFProps
    if $data(top) {set name $data(file)} \
    else {set name [file tail $data(file)]}
    wm title $w "$name Properties"
    wm resizable $w 1 0
    wm minsize $w 415 0
    if {[winfo viewable [winfo toplevel $data(-parent)]]} {
	wm transient $w $data(-parent)
    }

    if {![info exists Priv(FPropsImage)]} {
	set Priv(FPropsImage) [image create photo -data {
		R0lGODlhGgAtALMAANnZ2QQEBPz8/P///1RUVFRcZExURFxkVERUQFRUXERkNEx0RP//////
		/////////yH5BAEAAAAALAAAAAAaAC0AAAT/EMhJqwzBWktDgCJAICetNYQhRpABAjlpDUGM
		MUQIMAQI5KQzhCHGGCLAMEQAAAQI5AQhjDGGGCFAMcYIIIQAgZQhDDHGECEMKMYYIoQhAgAg
		wCDGGGKEIIYYA44QxBgjgBCGGHAMEcIQYwwRwoBiiDFCGEOMMQIMYogxRghiiBFgGCOEMYYI
		YYwBxRAhDDFECEMMOEIYY4QxxhAjwCCGGCEIOKQMYYYpQhhiQBHCEEOMMEYIA44RxhhhDDFC
		EHBIEYIcIcgR5IBhjBCGGGOEIAYcY4QwxghjjDDgEEMMEcIQcEgZwgwzTDFCgGKIIcYYI4Qx
		BgxjjDCGCGGIIWAI/3BIGcIMM8gghoAjBDHGEGOEMAYcYYwRxhBDhACHlCHIEGaYYQYYxBhD
		hDDEGCHAIYMcQQYpRwgCDilDmGGGKYYIMMAhpwxhhhmkGAEGAYecM4QZZpAhDCjgkJOGMMMM
		UgwBhwhhjCHCGCEMOEYYY4QxhgghQDHECEGMEcIYA4YxRhgjBDHEEDCEIcYYcowRxoAjjDHE
		GCMEMQQccoQwwwxSyBDgEEPAIWUIM8wwQxADijFCGGOMEMYYMIwxwhhhiDFGgEGMMcQIYYwR
		BhwjjDHEECHAIaUIAQQxRJgBiiFGCGKIIUYIEMgwRAhDjDBGgGGIMYYIgQAAAAwShDFEgG9D
		ThkCJFICEAAAYYgQ4JBiiBAgkbKYA4GUIQQSxhAjBEjkJOZAICUKhJAwRAiQyFnMgUBKhCCR
		MoQwSSKFKAjkVAUSOcOUiRgDgZz0GEjklIWYBYGclJoCiZyGQCAnrdIYUghZ1loThIyBQE5a
		QQQAOw==}]
    }
    if {![info exists Priv(DPropsImage)]} {
	set Priv(DPropsImage) [image create photo -data {
		R0lGODlhHwApAKIAANnZ2ZycBPz8/Pz8nDQ0BPzMnICAgP///yH5BAEAAAAALAAAAAAfACkA
		AAP/CLrczigCQZfbHUVIQCDocruiCJlRJARdbscImVGUIgRdbsYImVEUmSEEXd7ACIgQnIkQ
		wZoaQtBlCAwRCcGZCBGcKS1C0N0IFMFRjRCUmZrBmiEEXQ1BwdENEaypmcGaKULQhRAcXSVW
		VDNTg4SgG4Gjq0Q4U1qKVTMECAARgqNLRDhTWoo1M1NIABCCoxFDSDi6XIqlRQAIIROBQoSj
		W1M4NTOFU1MECBASgoKjy1o4NTWFU0UACCEhOLpbgzUzUzg1VYUEACEYgqPLWzg1M4VTQwAI
		ISE4ulyDNTM1WDVKgAAhITi6U4M1MzVYU1OFUwQAGBKCo8tTOFNThTVT/0UIGhKCo1pTOFNT
		ilWjWkgAEIIhOLpaizU1NViqBIAQEoKjWls4NTWFVVM1WAQAgRKCozu1WFNTg6VFBAgAIYEy
		MzU4NTWDU1NVOEWEoBsSKDi6W4M1VVVIhKCrIRgyNYUzNTVYUzWEBGBmCKohgYKjWlM4WkOE
		AGi6BoAQEjJYUzODNTVECICmywYYEjKDNTU1OEQAaLpsgAAhIThTOoVEAGi6bAiqIYEyNTVI
		BICmy4agCyEYMjOEBICmy4aguyEYMkSAgKbLhqDLEEhBBICmy4agyx0IgKbLhqDLvWi6bAi6
		3Iumy4agy71oumwIutwOyHQNQZfbG5ki6HL7ogEEADs=}]
    }
    if {![info exists Priv(DriveImage)]} {
	set Priv(DriveImage) [image create photo -data {
		R0lGODlhLwAmAMQAANnZ2WRkZHR0dICAgJSUlISEhJycnLS0tKSkpMDAwAQEBFxcXPz8/OTk
		5AT8BNTU1Nzc3ASEBMzMzDRkBMTExP//////////////////////////////////////////
		/yH5BAEAAAAALAAAAAAvACYAAAX/ICCOZEkGgSAIpmmapkkGgTAIxCAMpmmaJhMoCARhEIaB
		IARCAAFxJEvzJINAEAZhEAphKIaCEAQURckADIRBGIZBGIahIAiCMAhBAAFxJEtzDAJQEEdx
		GAaCKAiiIAzjKAoQEEeyLINAGARBGIRBGIRBGAqiIIjCMEAEOYoCBMSRLIEgEAZBEIRBGARh
		GAaiKIiCKAjQQJADOZCiAAFxJMUgAAVxFIZxEAuiIIiCMAjDMA7kOA7kKAoQEEcxCARhEAZB
		GARhEApBKISBGAqQEMXDQA4EOY7kSIoCBERRWRZQEMdxIAuhIAqCIAyDMAzjQJIjOY4kScCk
		KAAAUJZl/wkEYRAGQRCEQRCEQRgIogAJgyCQAwEPcUwOMBHFogCUJViWYBEEYRAGQRCEoigK
		oQAJUQQRUTySIznARBQZhikUcBHHYBGEQRCEQhiEgSgIgjAIBDmQAznA40iOI0kYpmmYQlmW
		YAmWJQgCYRAGoQCFQRiIwiAIA0GQ4ziSI0mShGEc52mYAlSCZQmWYAmWYAlAQRQHoSgKgjAM
		wzgQ5DiOI2EYKHKipwGZQlmWAFxEEQzEURiEYiAKgzAIwzCQ40iSg2Ek6Zki8HkgplCWZVmC
		YAmCJQiEQAgGoRgKgiBAwkAOBDkOhqEoSpKk5xEaplCWZQmWJQCXJVjAQBSFoP8giIIwCANB
		kINhDoqSJEqCBIEBIaZQlmBZliBYgiAQlkAIhEAIhoEgDANEEIZJjkM6KEoSBIYRGqYAFGUJ
		liVYFjAQAyEQAkEQAoEwCIRhDORAjkOiBIFhQEFgIKYAAEBRgmUJgmAJgkAIgkAIRNEAGcNA
		kOM4DkFgGEFgGAQpChAQRUUJlmAJhCAIhEAIBCEQBAIxDARBwEMQGEYQGAZBikIBAABYlmVR
		lGAJgkUAg0AQREEQBAIhDAMRBIYRBIZBkKJQFAAEAHARR1FRwEAUBVEQBCEQDMQwBIFhBIFh
		EKQoFAUAAQAAF3EkF0URAiEIhEAIBEEwEEJgGEFgGATTRIpCUZYFBMQRXMSRXBQlEIQgCARB
		EAzEYASBYRCkKBRQARdxBAFxBBdxJBdFCQJBEAJBMBBCYBgEKQpFKUkQEEcAXMSRXBRFCARB
		EAyEYBCkKBSlLEFAHElwEUdyURQhEAQCQZCiUJSyBAFxJElwEUdyURRBMJCiUJSyBAFxJMsR
		XMSRXBRFEBSlLEFAHMnSBMBFHMlFUcoSBMSRLM0SXMSRLEkQEEeyNE8RXMSRLEFAHMnSPE1w
		EUdyAQFxJEvzREVwEccFBMSRLM0TNZdlSVMxBAA7}]
    }

    if !$data(top) {
	file lstat $data(file) lstat
	set data(type) $lstat(type)
    }
    if $data(top) {
	set image $Priv(DriveImage)
	if {$tcl_platform(platform) == "windows"} {set type "Local disk"} \
	else {set type Toplevel}
	set lstat(size) 0
	set data(contains) "0 Files, 0 Folders"
	label $w.contains1 -text "Contains:"; label $w.contains2 -textvariable ${var}(contains)
    } elseif {$lstat(type) == "directory"} {
	set image $Priv(DPropsImage)
	set type "Directory"
	set lstat(size) 0
	set data(contains) "0 Files, 0 Folders"
	label $w.contains1 -text "Contains:"; label $w.contains2 -textvariable ${var}(contains)
    } else {
	set image $Priv(FPropsImage)
	if {$lstat(type) == "file"} {
	    set type [string trimleft [file extension $data(file)] .]
	} else {
	    set type $lstat(type)
	}
	set type [string toupper $type 0 0]		
	lappend type "File"
    }

    label $w.image -image $image -bd 0
    if $data(top) {
	label $w.name -text $name -anchor w
    } else {
	set data(entry) [entry $w.name -bg white -fg black]
	$w.name insert 0 $name
	if {$lstat(type) == "link"} {
	    label $w.link1 -text "Target:"; label $w.link2 -text "[file readlink $data(file)]"
	}
	label $w.loc1 -text "Location:"; label $w.loc2 -text [file dirname $data(file)]
    }

    frame $w.sep1 -bd 1 -relief sunken -height 2

    label $w.type1 -text "Type:"; label $w.type2 -text $type
    set shortSize [::tk::dialog::file::FormatSize $lstat(size)]
    set data(size) "$shortSize ([AddCommas $lstat(size)] bytes)"
    label $w.size1 -text "Size:"; label $w.size2 -textvariable ${var}(size)

    if !$data(top) {
	frame $w.sep2 -bd 1 -relief sunken -height 2
	set lstat(ctime) [clock format $lstat(ctime) -format "%A, %B %d, %Y, %I:%M:%S %p"]
	set lstat(mtime) [clock format $lstat(mtime) -format "%A, %B %d, %Y, %I:%M:%S %p"]
	set lstat(atime) [clock format $lstat(atime) -format "%A, %B %d, %Y, %I:%M:%S %p"]
	label $w.ctime1 -text "Created:"; label $w.ctime2 -text $lstat(ctime)
	label $w.mtime1 -text "Modified:"; label $w.mtime2 -text $lstat(mtime)
	label $w.atime1 -text "Accessed:"; label $w.atime2 -text $lstat(atime)

	frame $w.sep3 -bd 1 -relief sunken -height 2

	if {$tcl_platform(platform) == "windows"} {
	    set data(readonly) [file attributes $data(file) -readonly]
	    set data(hidden) [file attributes $data(file) -hidden]
	    set data(archive) [file attributes $data(file) -archive]
	    label $w.attrib1 -text "Attributes:"; set a2 [frame $w.attrib2 -bd 0]
	    checkbutton $a2.read -text "Read-only" -variable ${var}(readonly) -bd 0
	    checkbutton $a2.hidden -text "Hidden" -variable ${var}(hidden) -bd 0
	    checkbutton $a2.archive -text "Ready to archive" -variable ${var}(archive) -bd 0
	    grid $a2.read $a2.hidden -sticky w -pady 5; grid $a2.hidden -padx 60
	    grid $a2.archive - -sticky w -pady 5

	    frame $w.sep4 -bd 1 -relief sunken -height 2
	    set permissions ""
	    if [file readable $data(file)] {lappend permissions Read}
	    if [file writable $data(file)] {lappend permissions Write}
	    if [file executable $data(file)] {lappend permissions Execute}
	    if {$permissions != ""} {set permissions [join $permissions ", "]}
	    label $w.perm1 -text "Current user's permissions:" -wraplength 80 -justify left; label $w.perm2 -text $permissions
	} elseif {$tcl_platform(platform) == "unix" && $lstat(type) != "link"} {
	    set data(orig_perms) {}
	    set owner [file attributes $data(file) -owner]
	    set group [file attributes $data(file) -group]
	    set permissions [file attributes $data(file) -permissions]
	    set data(permissions) [string range $permissions 0 end-3]
	    set last3 [string range $permissions end-2 end]
	    label $w.perm1 -text Permissions
	    set p2 [frame $w.perm2frame -bd 0]
	    foreach win [list $p2.perm2 $p2.perm3 $p2.perm4] lab [list Read Write Execute] col [list 0 1 2] {
		label $win -text $lab
		grid $win -row 0 -column $col -padx 12 -sticky e
	    }
	    set p3 [frame $w.perm3frame -bd 2 -relief sunken -bg white]
	    grid columnconfigure $p3 0 -weight 1
	    foreach user [list "Owner ($owner)" "Group ($group)" "All Users"] row [list 0 1 2] n [split $last3 {}] {
		set userw [string tolower [lindex $user 0]]
		label $p3.$userw -text $user -bg white -fg black
		grid $p3.$userw -row $row -padx 12 -pady 7 -sticky w
		eval binary scan "\\0$n" B8 n
		set n [string range $n end-2 end]
		lappend data(orig_perms) $n
		foreach p [list r w e] column [list 1 2 3] val [split $n {}] {
		    set data(${userw}_$p) $val
		    FocusCheckButton $p3.${userw}_$p -variable ${var}(${userw}_$p) -bg white -highlightthickness 1 \
			    -takefocus 1 -highlightbackground white -width 17 -height 17
		    grid $p3.${userw}_$p -row $row -column $column -padx 24 -pady 7 -sticky e
		}
	    }
	}
    }

    set buts [frame $w.buts -bd 0] 
    button $buts.ok -text OK -pady 0 -command [list ::tk::dialog::fprops::OK $w 1]
    if !$data(top) {
	button $buts.cancel -text Cancel -pady 0 -command [list ::tk::dialog::fprops::Done $w]
	button $buts.apply -text Apply -pady 0 -command [list ::tk::dialog::fprops::OK $w]
	grid $buts.ok $buts.cancel $buts.apply -padx 5 -pady 5 -sticky nswe
	grid columnconfigure $buts [list 0 1 2] -minsize 110
    } else {
	grid $buts.ok -padx 5 -pady 5 -sticky nswe
	grid columnconfigure $buts 0 -minsize 110
    }
    grid rowconfigure $buts 0 -minsize 39

    grid $w.image $w.name -padx 12 -pady 12 -sticky we; grid $w.name -ipady 2
    if $data(top) {grid $w.image -padx 30}
    grid columnconfigure $w 1 -weight 1
    if {!$data(top) && $lstat(type) == "link"} {
	grid $w.link1 $w.link2 -padx 12 -pady 5 -sticky w
    }
    grid $w.sep1 - -sticky we -padx 12 -pady 5
    grid $w.type1 $w.type2 -padx 12 -pady 5 -sticky w
    if !$data(top) {grid $w.loc1 $w.loc2 -padx 12 -pady 5 -sticky w}
    grid $w.size1 $w.size2 -padx 12 -pady 5 -sticky w
    if {$data(top) || $lstat(type) == "directory"} {
	grid $w.contains1 $w.contains2 -padx 12 -pady 5 -sticky w
    }
    if !$data(top) {
	grid $w.sep2 - -padx 12 -pady 5 -sticky we
	grid $w.ctime1 $w.ctime2 -padx 12 -pady 5 -sticky w
	grid $w.mtime1 $w.mtime2 -padx 12 -pady 5 -sticky w
	grid $w.atime1 $w.atime2 -padx 12 -pady 5 -sticky w
	if {$lstat(type) != "link"} {grid $w.sep3 - -padx 12 -pady 5 -sticky we}
	if {$tcl_platform(platform) == "windows"} {
	    grid $w.attrib1 $a2 -padx 12 -sticky nw; grid $w.attrib1 -pady 5
	    grid $w.sep4 - -padx 12 -pady 5 -sticky we
	    grid $w.perm1 $w.perm2 -padx 12 -pady 5 -sticky w
	} elseif {$tcl_platform(platform) == "unix" && $lstat(type) != "link"} {
	    grid $w.perm1 $p2 -padx 12 -pady 5 -sticky e
	    grid $w.perm1 -sticky w
	    grid $p3 - -padx 12 -pady 5 -sticky we
	}
    }
    grid [frame $w.space -height 30 -bd 0] - -sticky we
    grid $buts - -sticky e

    wm protocol $w WM_DELETE_WINDOW [list ::tk::dialog::fprops::Done $w]
    bind $buts.ok <Return> "::tk::dialog::fprops::InvokeButton $buts.ok; break"
    if !$data(top) {
	bind $buts.cancel <Return> "::tk::dialog::fprops::InvokeButton $buts.cancel; break"
	bind $buts.apply <Return> "::tk::dialog::fprops::InvokeButton $buts.apply; break"
	if {$tcl_platform(platform) == "windows"} {
	    bind $a2.read <Return> "$a2.read invoke; break"
	    bind $a2.hidden <Return> "$a2.hidden invoke; break"
	    bind $a2.archive <Return> "$a2.archive invoke; break"
	}
    }
    bind $w <Return> [list ::tk::dialog::fprops::InvokeButton $buts.ok]

    update idletasks
    ::tk::SetFocusGrab $w $w
    if {$data(top) || $lstat(type) == "directory"} {after 100 [list ::tk::dialog::fprops::IterateSubFiles $w]}
    vwait $var:done
    set name [set $var:done]
    unset $var:done
    return $name
}

proc ::tk::dialog::fprops::InvokeButton {w} {
    event generate $w <Button-1>
    update idletasks
    after 150
    event generate $w <ButtonRelease-1>
    update idletasks
    if [winfo exists $w] {$w invoke}
}

proc ::tk::dialog::fprops::IterateSubFiles {w} {
    upvar ::tk::dialog::fprops::[winfo name $w] data

    set size 0; set nfiles 0; set nfolders 0
    set update 500
    set new_folders [list $data(file)]
    while {$new_folders != ""} {
	set folders $new_folders
	set new_folders {}
	foreach f $folders {
	    foreach file [glob -nocomplain -directory $f * .*] {
		update
		if ![info exists data] return
		if {[string index $file end] == "." || [string range $file end-1 end] == ".." || ![file exists $file]} continue
		if [file isdirectory $file] {
		    lappend new_folders $file
		    incr nfolders
		} else {
		    set size [expr {double($size) + [file size $file]}]
		    incr nfiles
		}
		if {$nfiles >= $update} {
		    set shortSize [::tk::dialog::file::FormatSize $size]
		    set data(size) "$shortSize ([AddCommas $size] bytes)"
		    set data(contains) "[AddCommas $nfiles] Files, [AddCommas $nfolders] Folders"
		    incr update 500
		}
	    }
	}
    }
    set shortSize [::tk::dialog::file::FormatSize $size]
    set data(size) "$shortSize ([AddCommas $size] bytes)"
    set data(contains) "[AddCommas $nfiles] Files, [AddCommas $nfolders] Folders"
}

proc ::tk::dialog::fprops::OK {w {close 0}} {
    upvar ::tk::dialog::fprops::[winfo name $w] data
    global tcl_platform

    if $data(top) {
	::tk::dialog::fprops::Done $w
	return
    }

    set name [$data(entry) get]
    set full_name [file join [file dirname $data(file)] $name]
    if {$full_name != $data(file)} {
	# Do rename
	set badname 1
	if {[file pathtype $name] != "relative"} {
	    set title "Bad name"
	    set mess "Just type the file name, not the path."
	    set prev_name [file tail $name]
	} else {
	    set prev_name [file tail $data(file)]
	    switch -- $name {
		{} {
		    set title Rename
		    set mess "You must type a name."
		}
		\\ - / - . - .. {
		    set title "Invalid name"
		    set mess "\"$name\" is invalid.  You must type a valid name."
		}
		default {
		    if [file exists $full_name] {
			set title "File or folder already exists"
			set mess "Cannot rename \"$prev_name\" to \"$name.\"\nThe file or folder already exists.  Please specify a different name."
		    } else {set badname 0}
		}
	    }
	}

	if !$badname {
	    if [catch {file rename -force -- $data(file) $full_name} res] {
		set badname 1
		set title Error
		set mess $res
	    }
	}
	if $badname {
	    $data(entry) delete 0 end
	    $data(entry) insert 0 $prev_name
	    $data(entry) selection range 0 end
	    $data(entry) icursor end
	    tk_messageBox -type ok -parent $w -icon warning -title $title -message $mess
	    return
	} else {
	    set data(file) $full_name
	}
    }

    if {$tcl_platform(platform) == "windows"} {
	catch {
	    file attributes $full_name -readonly $data(readonly)
	    file attributes $full_name -hidden $data(hidden)
	    file attributes $full_name -archive $data(archive)
	}
    } elseif {$tcl_platform(platform) == "unix" && $data(type) != "link"} {
	set permissions $data(permissions)
	foreach user [list owner group all] {
	    set bin {}
	    foreach p [list r w e] {append bin $data(${user}_$p)}
	    append permissions [scan [binary format B8 "00000$bin"] %c]
	}
	if [catch {file attributes $full_name -permissions $permissions} res] {
	    set err 0
	    foreach user [list owner group all] n $data(orig_perms) {
		foreach p [list r w e] val [split $n {}] {
		    if {[string compare $data(${user}_$p) $val]} {
			set ::tk::dialog::fprops::[winfo name $w](${user}_$p) $val
			set err 1
		    }
		}
	    }
	    if $err {tk_messageBox -type ok -parent $w -icon warning -title Error -message $res}
	}
    }

    if $close {::tk::dialog::fprops::Done $w}
}

proc ::tk::dialog::fprops::Done {w} {
    set dataName [winfo name $w]
    upvar ::tk::dialog::fprops::$dataName data

    ::tk::RestoreFocusGrab $w $w destroy
    set ::tk::dialog::fprops::$dataName:done $data(file)
    catch {unset data}
}

proc ::tk::dialog::fprops::AddCommas {size} {
    if {$size == "" || $size == 0} {return 0}
    set size "[lindex [split $size .] 0]"
    set len [string length $size]
    if {$len < 4} {return $size}
    set extra [expr {$len % 3}]
    if $extra {regsub -- "(.\{$extra\})" $size {\0,} size}
    regsub -all -start [expr {$extra ? $extra+1 : 0}] -- {(.{3})} $size {\0,} size
    return [string trimright $size ,]
}

proc ::tk::dialog::fprops::FocusCheckButton {w args} {
    set args2 {}
    foreach {var val} $args {
	if {$var == "-variable"} {set variable $val} \
	else {lappend args2 $var $val}
    }
    if ![info exists variable] {
	set variable "[lindex [split $w .] end]"
    }
    set variable "::[string trimleft $variable :]"
    if ![info exists $variable] {set $variable 0}
    eval canvas $w $args2
    $w create rectangle 4 4 15 15 -outline black -width 2
    set item [$w create rectangle 4 4 15 15 -outline "" -fill ""]
    ::tk::dialog::fprops::ToggleCheckButton $w $variable {} w
    trace variable $variable w [list ::tk::dialog::fprops::ToggleCheckButton $w]
    $w bind $item <ButtonRelease-1> [list ::tk::dialog::fprops::ToggleCheckButton $w $variable]
    bind $w <Return> "::tk::dialog::fprops::ToggleCheckButton $w $variable; break"
}

proc ::tk::dialog::fprops::ToggleCheckButton {w var {var2 ""} {op ""}} {
    if {$op != "w" && $op != ""} return
    if {$var2 != ""} {set var "${var}($var2)"}
    if {$op == ""} {
	set $var [expr {![set $var]}]
    }
    if [set $var] {
	if {[$w find withtag check] == ""} { 
	    $w create polygon 6 8 6 10 8 12 12 8 12 6 8 10 -fill black -outline black -tags check
	    $w lower check
	}
    } else {
	$w delete check
    }
}

