1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
|
# $Id: s.Serializer.xotcl 1.4 01/03/23 21:55:33+01:00 neumann@somewhere.wu-wien.ac.at $
package require XOTcl 0.84
package provide xotcl::scriptCreation::serializer 0.1
@ @File {
description {
This package provides the class Serializer, which can be used to
generate a snapshot of the current state of the workspace
in the form of an XOTcl source code
}
authors {
Gustaf Neumann, Gustaf.Neumann@wu-wien.ac.at
Uwe Zdun, uwe.zdun@uni-essen.de
}
date { $Date: 01/03/23 21:55:33+01:00 $ }
}
@ Serializer instproc serializeWs {?fn? "optional filename"} {
Description {
Serialize all objects and classes that are currently
defined. If fn is not specified the function returns the source
code to recreate the workspace. If fn is specified the source
code is written into the specified file.
}
return "script or empty string"
}
@ Serializer instproc serialize {entity "Object or Class"} {
Description {
Serialize the specified object or class.
}
return {Object or Class with all currently defined methods,
variables, invariants, filters and mixins}
}
Class Serializer
Serializer instproc ignore args {
foreach i $args { [self] set skip($i) 1 }
}
Serializer instproc init {} {
[self] ignore [self] [self class] \
::Class ::Object ::Object::CopyHandler ::Class::Parameter \
::@ ::xotcl ::xotcl::rcs
}
Serializer instproc method-serialize {o m prefix} {
set arglist ""
foreach v [$o info ${prefix}args $m] {
if {[$o info ${prefix}default $m $v x]} {
lappend arglist [list $v $x] } {
lappend arglist $v }
}
lappend r $o ${prefix}proc $m $arglist [$o info ${prefix}body $m]
foreach p {pre post} {
if {[$o info ${prefix}$p $m]!=""} {lappend r [$o info ${prefix}$p $m]}
}
return $r
}
Serializer instproc Object-serialize o {
append cmd [list [$o info class] create $o \
-mixin ::xotcl::NoInit -init -mixin {}] \n
foreach i [$o info procs] {
append cmd [[self] method-serialize $o $i ""] \n
}
foreach v [$o info vars] {
if {[$o array exists $v]} {
append cmd [list $o array set $v [$o array get $v]] \n
} else {
append cmd [list $o set $v [$o set $v]] \n
}
}
foreach x {mixin invar} {
if {[$o info $x] != ""} {append cmd [list $o $x [$o info $x]] \n}
}
return $cmd
}
Serializer instproc Class-serialize o {
set cmd [[self] Object-serialize $o]
foreach i [$o info instprocs] {
append cmd [[self] method-serialize $o $i inst] \n
}
foreach x {superclass instmixin filter instinvar} {
if {[$o info $x]!=""} {append cmd [list $o $x [$o info $x]] \n}
}
return $cmd\n
}
Serializer instproc args {o prefix m} {
foreach v [$o info ${prefix}args $m] {
if {[$o info ${prefix}default $m $v x]} {
lappend arglist [list $v $x] } {
lappend arglist $v }
}
return $arglist
}
Serializer instproc category c {
if {[$c istype ::Class]} {return Class} {return Object}
}
Serializer instproc allInstances C {
set set [$C info instances]
foreach sc [$C info subclass] {
eval lappend set [[self] allInstances $sc]
}
return $set
}
Serializer instproc topoSort {set} {
if {[[self] array exists s]} {[self] array unset s}
foreach c $set {
if {[[self] exists skip($c)]} continue
[self] set s($c) 1
}
set stratum 0
while {1} {
set set [[self] array names s]
if {[llength $set] == 0} break
incr stratum
#puts "$stratum set=$set"
[self] set level($stratum) {}
foreach c $set {
if {[[self] [[self] category $c]-needsNothing $c]} {
[self] lappend level($stratum) $c
}
}
foreach i [[self] set level($stratum)] {[self] unset s($i)}
}
}
Serializer instproc Class-needsNothing x {
if {![[self] Object-needsNothing $x]} {return 0}
if {[[self] needsOneOf [$x info superclass]]} {return 0}
if {[[self] needsOneOf [$x info instmixin ]]} {return 0}
return 1
}
Serializer instproc Object-needsNothing x {
set p [$x info parent]
if {$p != "::" && [[self] needsOneOf $p]} {return 0}
if {[[self] needsOneOf [$x info class]]} {return 0}
if {[[self] needsOneOf [$x info mixin ]]} {return 0}
return 1
}
Serializer instproc needsOneOf list {
foreach e $list {if {[[self] exists s($e)]} {return 1}}
return 0
}
Serializer instproc serialize {objectOrClass} {
[self] [[self] category $objectOrClass]-serialize $objectOrClass
}
Serializer instproc serializeWs {{fn ""}} {
[self] topoSort [[self] allInstances ::Object]
#foreach i [lsort [[self] array names level]] {
# puts "$i: [[self] set level($i)]"
#}
set result ""
foreach l [lsort [[self] array names level]] {
foreach i [[self] set level($l)] {
append result [[self] serialize $i]
}
}
if {$fn == ""} {
return $result
} else {
set f [open $fn w]
puts $f $result
close $f
}
}
|
