1# -*- tcl -*-
2#
3# dateentry.tcl -
4#
5#       dateentry widget
6#
7# This widget provides an entry with a visual calendar for
8# choosing a date. It is mostly a gathering compoments.
9#
10# The basics for the entry were taken from the "MenuEntry widget"
11# of the widget package in the tklib.
12# The visual calendar is taken from http://wiki.tcl.tk/1816.
13#
14# So many thanks to Richard Suchenwirth for visual calendar
15# and to Jeff Hobbs for the widget package in tklib.
16#
17# See the example at the bottom.
18#
19# RCS: @(#) $Id: dateentry.tcl,v 1.4 2010/06/01 18:06:52 hobbs Exp $
20#
21
22# Creation and Options - widget::dateentry $path ...
23#  -command        -default {}
24#  -dateformat     -default "%m/%d/%Y"
25#  -font           -default {Helvetica 9}
26#  -background     -default white
27#  -textvariable   -default {}  -configuremethod C-textvariable
28#
29# Following are passed to widget::calendar component:
30#  -firstday
31#  -highlightcolor
32#
33# Methods
34#  $widget post   - display calendar dropdown
35#  $widget unpost - remove calendar dropdown
36#  All other methods to entry
37#
38# Bindings
39#  NONE
40#
41
42###
43
44package require widget
45package require widget::calendar
46
47namespace eval ::widget {
48    # http://www.famfamfam.com/lab/icons/mini/
49    # ?Mini? is a set of 144 GIF icons available for free use for any purpose.
50    variable dateentry_gifdata {
51	R0lGODlhEAAQAMQAANnq+K7T5HiUsMHb+v/vlOXs9IyzzHWs1/T5/1ZtjUlVa+z1/+3
52	x9uTx/6a2ysng+FFhe0NLXIDG/fD4/ykxQz5FVf/41vr8/6TI3MvM0XHG/vbHQPn8//
53	b8/4PL/f///yH5BAAAAAAALAAAAAAQABAAAAWV4Cdam2h+5AkExCYYsCC0iSAGTisAP
54	JC7kNvicPBIjkeiIyHCMDzQaFRTYH4wBY6W0+kgvpNC8GNgXLhd8CQ8Lp8f3od8sSgo
55	RIasHPGY0AcNdiIHBV0PfHQNgAURIgKFfBMPCw2KAIyOkH0LA509FY4TXn6UDT0MoB8
56	JDwwFDK+wrxkUjgm2EBAKChERFRUUYyfCwyEAOw==
57    }
58    # http://www.famfamfam.com/lab/icons/silk/
59    # ?Silk? is a smooth, free icon set,
60    variable dateentry_gifdata {
61	R0lGODlhEAAQAPZ8AP99O/9/PWmrYmytZW6uaHOxbP+EQv+LR/+QTf+UUv+VVP+WVP+
62	YV/+ZWP+aWv+dXP+eXf+fX/+nVP+rWv+gYP+hYf+iYv+jZP+kZP+kZf+wYf+zaP+4bf
63	+5cf+7df+9eUJ3u1KEw1SGxFWGxlaHx12KxVyKxl+MxlmKyFuKyV+NyF6Oy1+Py2OSz
64	mSTzmiW0WqX0W6Z02+b1HKe1nSg13Wh13qj2nqk2X2l3H6o3ZHBjJvHlqXNoa/Sq4Cp
65	3YOr3IKq34mu2Yyw24mw3pG03Za434Ss4Ieu4Yiv4oyx44+14Yyy5I+05ZC15pO355S
66	355W445294Zq75p++5pa66Zi66Zq865u9652+656/7KG/55/A7aTB5KTB56vG5abD6a
67	HB7qLB76rG6a7J6rLL6rfO6rrQ67zQ68PdwNfp1dji8Nvk8d7n8t7n8+Lq9Obt9urw9
68	+vx9+3y+O7z+e/z+fD0+vH2+vL2+vT3+/n8+f7+/v7//v///wAAAAAAAAAAACH5BAEA
69	AH0ALAAAAAAQABAAAAfMgH2Cg4SFg2FbWFZUTk1LSEY+ODaCYHiXmJmXNIJZeBkXFBA
70	NCwgHBgF4MoJXeBgfHh0cGxoTEgB4MIJVnxcWFREPDgwKCXgugk94X3zNzs1ecSyCTH
71	difD0FaT0DPXxcbCiCSXZjzQJpO3kFfFFqI4JHdWTnaTp8AnxFaiKCQHRl+KARwKMHA
72	W9E1KgQlIOOGT569uyB2EyIGhOCbsw500XLFClQlAz5EUTNCUE15MB546bNGjUwY5YQ
73	NCPGixYrUpAIwbMnCENACQUCADs=
74    }
75}
76
77proc ::widget::createdateentryLayout {} {
78    variable dateentry
79    if {[info exists dateentry]} { return }
80    set dateentry 1
81    variable dateentry_pngdata
82    variable dateentry_gifdata
83    set img ::widget::img_dateentry
84    image create photo $img -format GIF -data $dateentry_gifdata
85    namespace eval ::ttk [list set dateimg $img] ; # namespace resolved
86    namespace eval ::ttk {
87	# Create -padding for space on left and right of icon
88	set pad [expr {[image width $dateimg] + 6}]
89	style theme settings "default" {
90	    style layout dateentry {
91		Entry.field -children {
92		    dateentry.icon -side left
93		    Entry.padding -children {
94			Entry.textarea
95		    }
96		}
97	    }
98	    # center icon in padded cell
99	    style element create dateentry.icon image $dateimg \
100		-sticky "" -padding [list $pad 0 0 0]
101	}
102	if 0 {
103	    # Some mappings would be required per-theme to adapt to theme
104	    # changes
105	    foreach theme [style theme names] {
106		style theme settings $theme {
107		    # Could have disabled, pressed, ... state images
108		    #style map dateentry -image [list disabled $img]
109		}
110	    }
111	}
112    }
113}
114
115snit::widgetadaptor widget::dateentry {
116    delegate option * to hull
117    delegate method * to hull
118
119    option -command -default {}
120    option -dateformat -default "%m/%d/%Y" -configuremethod C-passtocalendar
121    option -font -default {Helvetica 9} -configuremethod C-passtocalendar
122    option -textvariable -default {}
123
124    delegate option -highlightcolor to calendar
125    delegate option -firstday to calendar
126
127    component dropbox
128    component calendar
129
130    variable waitVar
131    variable formattedDate
132    variable rawDate
133    variable startOnMonday 1
134
135    constructor args {
136	::widget::createdateentryLayout
137
138	installhull using ttk::entry -style dateentry
139
140	bindtags $win [linsert [bindtags $win] 1 TDateEntry]
141
142	$self MakeCalendar
143
144	$self configurelist $args
145
146	set now [clock seconds]
147	set x [clock format $now -format "%d/%m%/%Y"]
148	set rawDate [clock scan "$x 00:00:00" -format "%d/%m%/%Y %H:%M:%S"]
149	set formattedDate [clock format $rawDate -format $options(-dateformat)]
150
151	$hull configure -state normal
152	$hull delete 0 end
153	$hull insert end $formattedDate
154	$hull configure -state readonly
155    }
156
157    method C-passtocalendar {option value} {
158	set options($option) $value
159	$calendar configure $option $value
160    }
161
162    method MakeCalendar {args} {
163	set dropbox $win.__drop
164	destroy $dropbox
165	toplevel $dropbox -takefocus 0
166	wm withdraw $dropbox
167
168	if {[tk windowingsystem] ne "aqua"} {
169	    wm overrideredirect $dropbox 1
170	} else {
171	    tk::unsupported::MacWindowStyle style $dropbox \
172		help {noActivates hideOnSuspend}
173	}
174	wm transient $dropbox [winfo toplevel $win]
175	wm group     $dropbox [winfo parent $win]
176	wm resizable $dropbox 0 0
177
178	# Unpost on Escape or whenever user clicks outside the dropdown
179	bind $dropbox <Escape> [list $win unpost]
180	bind $dropbox <ButtonPress> [subst -nocommands {
181	    if {[string first "$dropbox" [winfo containing %X %Y]] != 0} {
182		$win unpost
183	    }
184	}]
185
186	set calendar $dropbox.calendar
187	widget::calendar $calendar -command [mymethod DateChosen] \
188	    -textvariable [myvar formattedDate] \
189	    -dateformat $options(-dateformat) \
190	    -font $options(-font) \
191	    -borderwidth 1 -relief solid
192
193	pack $calendar -expand 1 -fill both
194
195	return $dropbox
196    }
197
198    method post { args } {
199	# XXX should we reset date on each display?
200	if {![winfo exists $dropbox]} { $self MakeCalendar }
201	set waitVar 0
202
203	foreach {x y} [$self PostPosition] { break }
204	wm geometry $dropbox "+$x+$y"
205	wm deiconify $dropbox
206	raise $dropbox
207
208	if {[tk windowingsystem] ne "aqua"} {
209	    tkwait visibility $dropbox
210	}
211
212	ttk::globalGrab $dropbox
213	focus -force $calendar
214	return
215
216	tkwait variable [myvar waitVar]
217
218	$self unpost
219    }
220
221    method unpost {args} {
222	ttk::releaseGrab $dropbox
223	wm withdraw $dropbox
224    }
225
226    method PostPosition {} {
227	# PostPosition --
228	#	Returns the x and y coordinates where the menu
229	#	should be posted, based on the dateentry and menu size
230	#	and -direction option.
231	#
232	# TODO: adjust menu width to be at least as wide as the button
233	#	for -direction above, below.
234	#
235	set x [winfo rootx $win]
236	set y [winfo rooty $win]
237	set dir "below" ; #[$win cget -direction]
238
239	set bw [winfo width $win]
240	set bh [winfo height $win]
241	set mw [winfo reqwidth $dropbox]
242	set mh [winfo reqheight $dropbox]
243	set sw [expr {[winfo screenwidth  $dropbox] - $bw - $mw}]
244	set sh [expr {[winfo screenheight $dropbox] - $bh - $mh}]
245
246	switch -- $dir {
247	    above { if {$y >= $mh} { incr y -$mh } { incr y  $bh } }
248	    below { if {$y <= $sh} { incr y  $bh } { incr y -$mh } }
249	    left  { if {$x >= $mw} { incr x -$mw } { incr x  $bw } }
250	    right { if {$x <= $sw} { incr x  $bw } { incr x -$mw } }
251	}
252
253	return [list $x $y]
254    }
255
256    method DateChosen { args } {
257	upvar 0 $options(-textvariable) date
258
259	set waitVar 1
260	set date $formattedDate
261	set rawDate [clock scan $formattedDate -format $options(-dateformat)]
262	if { $options(-command) ne "" } {
263	    uplevel \#0 $options(-command) $formattedDate $rawDate
264	}
265	$self unpost
266
267	$hull configure -state normal
268	$hull delete 0 end
269	$hull insert end $formattedDate
270	$hull configure -state readonly
271    }
272}
273
274# Bindings for menu portion.
275#
276# This is a variant of the ttk menubutton.tcl bindings.
277# See menubutton.tcl for detailed behavior info.
278#
279
280bind TDateEntry <Enter>     { %W state active }
281bind TDateEntry <Leave>     { %W state !active }
282bind TDateEntry <<Invoke>>  { %W post }
283bind TDateEntry <Control-space> { %W post }
284bind TDateEntry <Escape>        { %W unpost }
285
286bind TDateEntry <ButtonPress-1> { %W state pressed ; %W post }
287bind TDateEntry <ButtonRelease-1> { %W state !pressed }
288
289package provide widget::dateentry 0.92
290
291##############
292# TEST CODE ##
293##############
294
295if { [info script] eq $argv0 } {
296
297    proc getDate { args } {
298	puts [info level 0]
299	puts "DATE $::DATE"
300
301	update
302    }
303
304    proc dateTrace { args } {
305	puts [info level 0]
306    }
307
308    # Samples
309    # package require widget::dateentry
310    set ::DATE ""
311    set start [widget::dateentry .s -textvariable ::DATE \
312		   -dateformat "%d.%m.%Y %H:%M" \
313		   -command [list getDate .s]]
314    set end [widget::dateentry .e \
315		 -command [list getDate .e] \
316		 -highlightcolor dimgrey \
317		 -font {Courier 10} \
318		 -firstday sunday]
319    grid [label .sl -text "Start:"] $start  -padx 4 -pady 4
320    grid [label .el -text "End:"  ] $end    -padx 4 -pady 4
321
322    trace add variable ::DATE write dateTrace
323    set ::DATE 1
324
325    puts [$end get]
326}
327