1# -*- mode: tcl; fill-column: 75; tab-width: 8; coding: iso-latin-1-unix -*-
2#
3#	$Id: Object.tcl,v 1.3 2006-10-01 23:59:47 villate Exp $
4#
5# Original Id: object.tcl,v 1.7 1995/02/10 08:32:50 sls Exp sls
6#
7# This software is copyright (C) 1994 by the Lawrence Berkeley Laboratory.
8#
9# Redistribution and use in source and binary forms, with or without
10# modification, are permitted provided that: (1) source code distributions
11# retain the above copyright notice and this paragraph in its entirety, (2)
12# distributions including binary code include the above copyright notice and
13# this paragraph in its entirety in the documentation or other materials
14# provided with the distribution, and (3) all advertising materials mentioning
15# features or use of this software display the following acknowledgement:
16# ``This product includes software developed by the University of California,
17# Lawrence Berkeley Laboratory and its contributors.'' Neither the name of
18# the University nor the names of its contributors may be used to endorse
19# or promote products derived from this software without specific prior
20# written permission.
21#
22# THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR IMPLIED
23# WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
24# MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.
25
26# Prepare for message catalogues
27proc M {str args} {
28    if {$args == ""} {return $str}
29    return [eval [list format $str] $args]
30}
31
32proc object_info {name} {
33    # need an object info function like itcl
34}
35
36set object_priv(currentClass) {}
37set object_priv(objectCounter) 0
38
39proc object_class {name spec} {
40    global object_priv
41    set object_priv(currentClass) $name
42    lappend object_priv(objects) $name
43    upvar #0 ${name}_priv class
44    set class(members) {}
45    set class(params) {}
46    set class(methods) {}
47    proc doc arg "upvar #0 ${name}_priv class; set class(__doc__) \"\$arg\""
48    eval $spec
49    proc doc arg ""
50    proc $name:config {self args} "uplevel \[concat object_config \$self \$args]"
51    proc $name:configure args "uplevel \[concat object_config \$args]"
52    proc $name:cget {self option} "uplevel \[list object_cget \$self \$option]"
53    proc $name {inst args} "object_new $name \$inst; uplevel \[concat object_config \$inst \$args]"
54}
55
56
57# could do doc as a simple proc that finds if its in a method or a class
58# use uplevel and/or look for self as first of info args
59
60proc method {name args body} {
61    global object_priv
62    set className $object_priv(currentClass)
63    upvar #0 ${className}_priv class
64    lappend class(methods) $name
65    set methodArgs self
66    append methodArgs " " $args
67    set procbody "upvar #0 \$self slot"
68    append procbody "\nproc doc arg \"upvar #0 \$self slot; set slot(${name}.__doc__) \\\$arg\""
69    append procbody "\n$body"
70    proc $className:$name $methodArgs $procbody
71}
72
73# Pythonic method without the implicit self
74proc def {name args body} {
75    global object_priv
76    set className $object_priv(currentClass)
77    upvar #0 ${className}_priv class
78    lappend class(methods) $name
79    set methodArgs $args
80    set procbody "set self \$[lindex $methodArgs 0]; upvar #0 \$self slot"
81    append procbody "\nproc doc arg \"upvar #0 \$self slot; set slot(${name}.__doc__) \\\$arg\""
82    append procbody "\n$body"
83    proc $className:$name $methodArgs $procbody
84}
85
86proc member {name {defaultValue {}}} {
87    global object_priv
88    set className $object_priv(currentClass)
89    upvar #0 ${className}_priv class
90    if {![info exists class(member_info/$name)]} {
91	lappend class(members) [list $name $defaultValue]
92    }
93    set class(member_info/$name) {}
94}
95
96proc param {name {defaultValue {}} {resourceClass {}} {configCode {}}} {
97    global object_priv
98    set className $object_priv(currentClass)
99    upvar #0 ${className}_priv class
100    if {$resourceClass == ""} {
101	set resourceClass \
102	    [string toupper [string index $name 0]][string range $name 1 end]
103    }
104    if ![info exists class(param_info/$name)] {
105	lappend class(params) $name
106    }
107    set class(param_info/$name) [list $defaultValue $resourceClass]
108    if {$configCode != {}} {
109	proc $className:config:$name self $configCode
110    }
111}
112
113proc object_include {args} {
114    global object_priv
115    set className $object_priv(currentClass)
116    foreach super_class_name $args {
117	if {[info procs $super_class_name] == ""} {auto_load $super_class_name}
118	upvar #0 ${className}_priv class
119	upvar #0 ${super_class_name}_priv super_class
120	foreach p $super_class(params) {
121	    lappend class(params) $p
122	    set class(param_info/$p) $super_class(param_info/$p)
123	}
124	set class(members) [concat $super_class(members) $class(members)]
125	foreach m $super_class(methods) {
126	    set formals {}
127	    set proc $super_class_name:$m
128	    foreach arg [info args $proc] {
129		if {[info default $proc $arg def]} {
130		    lappend formals [list $arg $def]
131		} else {
132		    lappend formals $arg
133		}
134	    }
135	    proc $className:$m $formals [info body $proc]
136	}
137    }
138}
139
140proc object_new {className {name {}}} {
141    if {$name == {}} {
142	global object_priv
143	set name O_[incr object_priv(objectCounter)]
144    }
145    upvar #0 $name object
146    upvar #0 ${className}_priv class
147    set object(__class__) $className
148    set object(__file__) [info script]
149    foreach var $class(params) {
150	set info $class(param_info/$var)
151	set resourceClass [lindex $info 1]
152	if {$resourceClass != "" && \
153		![catch {set val [option get $name $var $resourceClass]}]} {
154	    if {$val == ""} {
155		set val [lindex $info 0]
156	    }
157	} else {
158	    set val [lindex $info 0]
159	}
160	set object($var) $val
161    }
162    foreach var $class(members) {
163	set object([lindex $var 0]) [lindex $var 1]
164    }
165    proc $name {method args} [format {
166	upvar #0 %s object
167	uplevel [concat $object(__class__):$method %s $args]
168    } $name $name]
169    if {[info procs ${className}:__init__] != ""} {
170	$name  __init__
171    } elseif {[info procs ${className}:create] != ""} {
172	$name  create
173    }
174    return $name
175}
176
177proc object_define_creator {windowType name spec} {
178    object_class $name $spec
179    if {[info procs $name:create] == {} && [info procs $name:__init__] == {}} {
180	error "widget \"$name\" must define a create method"
181    }
182    if {[info procs $name:reconfig] == {}} {
183	error "widget \"$name\" must define a reconfig method"
184    }
185    proc $name {window args} [format {
186	if {[winfo exists $window]} {destroy $window}
187	# need to transfer option database from Toplevel/Frame if we use -class
188	%s $window -class %s
189	rename $window object_window_of$window
190	upvar #0 $window object
191	set object(__window__) $window
192	object_new %s $window
193	proc %s:frame {self args} \
194	    "uplevel \[concat object_window_of$window \$args]"
195	uplevel [concat $window config $args]
196	# __init__ is a required method
197	if {![catch {$window __init__} err]} {
198	    # create is the oldname
199	} elseif {[catch {$window create} err]} {
200	    tk_messageBox -icon error -type ok \
201		    -message "Error creating widget \"$window\":\n$err"
202	    error "Error creating $window:\n$err"
203	}
204	set object(__created) 1
205	bind $window <Destroy> \
206	    "if !\[string compare %%W $window\] { object_delete $window }"
207	# reconfig is a required method
208	$window reconfig
209	return $window
210    } $windowType \
211	  [string toupper [string index $name 0]][string range $name 1 end] \
212	  $name $name]
213}
214
215# Class creators and their synonyms
216proc object_frame {name spec} {
217    # need to transfer option database from Frame to widget?
218    object_define_creator frame $name $spec
219}
220proc widget {args} {
221    eval object_frame $args
222}
223
224proc object_toplevel {name spec} {
225    # need to transfer option database from Toplevel to widget?
226    object_define_creator toplevel $name $spec
227}
228proc dialog {args} {
229    eval object_toplevel $args
230}
231
232auto_load auto_reset
233set arglist {name args}
234set body {
235    variable index
236    variable scriptFile
237    # Do some fancy reformatting on the "source" call to handle platform
238    # differences with respect to pathnames.  Use format just so that the
239    # command is a little easier to read (otherwise it'd be full of
240    # backslashed dollar signs, etc.
241    append index [list set auto_index([fullname $name])] \
242	    [format { [list source [file join $dir %s]]} \
243	    [file split $scriptFile]] "\n"
244}
245foreach elt {widget dialog object_toplevel object_frame} {
246    auto_mkindex_parser::command $elt $arglist $body
247}
248
249auto_mkindex_parser::command object_class {name args} {
250    variable index
251    variable scriptFile
252    # Do some fancy reformatting on the "source" call to handle platform
253    # differences with respect to pathnames.  Use format just so that the
254    # command is a little easier to read (otherwise it'd be full of
255    # backslashed dollar signs, etc.
256    append index [list set auto_index([fullname $name])] \
257	    [format { [list source [file join $dir %s]]} \
258	    [file split $scriptFile]] "\n"
259}
260
261
262proc object_config {self args} {
263    upvar #0 $self object
264    set len [llength $args]
265    if {$len == 0} {
266	upvar #0 $object(__class__)_priv class
267	set result {}
268	if {![info exists class(params)]} {
269	    return {}
270	}
271	foreach param $class(params) {
272	    set info $class(param_info/$param)
273	    lappend result \
274		[list -$param $param [lindex $info 1] [lindex $info 0] \
275		 $object($param)]
276	}
277	if {[info exists object(__window__)]} {
278	    set result [concat $result [object_window_of$object(__window__) config]]
279	}
280	return $result
281    }
282    if {$len == 1} {
283	upvar #0 $object(__class__)_priv class
284	if {[string index $args 0] != "-"} {
285	    error "param '$args' didn't start with dash"
286	}
287	set param [string range $args 1 end]
288	if {![info exists class(params)]} {
289	    error "Attempt to query an undeclared param: $param"
290	}
291	if {[set ndx [lsearch -exact $class(params) $param]] == -1} {
292	    if {[info exists object(__window__)]} {
293		return [object_window_of$object(__window__) config -$param]
294	    }
295	    error "no param '$args'"
296	}
297	set info $class(param_info/$param)
298	return [list -$param $param [lindex $info 1] [lindex $info 0] \
299		$object($param)]
300    }
301    # accumulate commands and eval them later so that no changes will take
302    # place if we find an error
303    set cmds ""
304    while {$args != ""} {
305	set fieldId [lindex $args 0]
306        if {[string index $fieldId 0] != "-"} {
307            error "param '$fieldId' didn't start with dash"
308        }
309        set fieldId [string range $fieldId 1 end]
310        if ![info exists object($fieldId)] {
311	    if {[info exists object(__window__)]} {
312		if {[catch [list object_window_of$object(__window__) config -$fieldId]]} {
313		    error "tried to set param '$fieldId' which did not exist."
314		} else {
315		    lappend cmds \
316			[list object_window_of$object(__window__) config -$fieldId [lindex $args 1]]
317		    set args [lrange $args 2 end]
318		    continue
319		}
320	    }
321
322        }
323	if {[llength $args] == 1} {
324	    return $object($fieldId)
325	} else {
326	    lappend cmds [list set object($fieldId) [lindex $args 1]]
327	    if {[info procs $object(__class__):config:$fieldId] != {}} {
328		lappend cmds [list $self config:$fieldId]
329	    }
330	    set args [lrange $args 2 end]
331	}
332    }
333    foreach cmd $cmds {
334	eval $cmd
335    }
336    if {[info exists object(__created)] && [info procs $object(__class__):reconfig] != {}} {
337	$self reconfig
338    }
339}
340
341proc object_cget {self var} {
342    upvar #0 $self object
343    return [lindex [object_config $self $var] 4]
344}
345
346proc object_delete self {
347    upvar #0 $self object
348    if {[info exists object(__class__)] && [info commands $object(__class__):destroy] != ""} {
349	catch {$object(__class__):destroy $self}
350    }
351    if {[info exists object(__window__)]} {
352	if {[string length [info commands object_window_of$self]]} {
353	    catch {rename $self {}}
354	    rename object_window_of$self $self
355	}
356	destroy $self
357    }
358    catch {unset object}
359}
360
361proc object_slotname slot {
362    upvar self self
363    return [set self]($slot)
364}
365