← Back to branch summary

~ubuntu-branches/ubuntu/maverick/evolution-data-server/maverick-proposed

« back to all changes in this revision

Viewing changes to libdb/test/upgrade.tcl

  • Committer: Bazaar Package Importer
  • Author(s): Didier Roche
  • Date: 2010-05-17 17:02:06 UTC
  • mfrom: (1.1.79 upstream) (1.6.12 experimental)
  • Revision ID: james.westby@ubuntu.com-20100517170206-4ufr52vwrhh26yh0
Tags: 2.30.1-1ubuntu1
https://launchpad.net/bugs/42199
https://launchpad.net/bugs/229669
https://launchpad.net/bugs/173703
https://launchpad.net/bugs/360344
https://launchpad.net/bugs/508494
* Merge from debian experimental. Remaining change:
  (LP: #42199, #229669, #173703, #360344, #508494)
  + debian/control:
    - add Vcs-Bzr tag
    - don't use libgnome
    - Use Breaks instead of Conflicts against evolution 2.25 and earlier.
  + debian/evolution-data-server.install,
    debian/patches/45_libcamel_providers_version.patch:
    - use the upstream versioning, not a Debian-specific one 
  + debian/libedata-book1.2-dev.install, debian/libebackend-1.2-dev.install,
    debian/libcamel1.2-dev.install, debian/libedataserverui1.2-dev.install:
    - install html documentation
  + debian/rules:
    - don't build documentation it's shipped with the tarball

Show diffs side-by-side

added added

removed removed

Lines of Context:
libdb/test/upgrade.tcl
1
 
# See the file LICENSE for redistribution information.
2
 
#
3
 
# Copyright (c) 1999-2002
4
 
#       Sleepycat Software.  All rights reserved.
5
 
#
6
 
# $Id$
7
 
 
8
 
source ./include.tcl
9
 
 
10
 
global upgrade_dir
11
 
# set upgrade_dir "$test_path/upgrade_test"
12
 
set upgrade_dir "$test_path/upgrade/databases"
13
 
 
14
 
global gen_upgrade
15
 
set gen_upgrade 0
16
 
 
17
 
global upgrade_dir
18
 
global upgrade_be
19
 
global upgrade_method
20
 
global upgrade_name
21
 
 
22
 
proc upgrade { { archived_test_loc "DEFAULT" } } {
23
 
        source ./include.tcl
24
 
        global upgrade_dir
25
 
 
26
 
        set saved_upgrade_dir $upgrade_dir
27
 
 
28
 
        puts -nonewline "Upgrade test: "
29
 
        if { $archived_test_loc == "DEFAULT" } {
30
 
                puts "using default archived databases in $upgrade_dir."
31
 
        } else {
32
 
                set upgrade_dir $archived_test_loc
33
 
                puts "using archived databases in $upgrade_dir."
34
 
        }
35
 
 
36
 
        foreach version [glob $upgrade_dir/*] {
37
 
                if { [string first CVS $version] != -1 } { continue }
38
 
                regexp \[^\/\]*$ $version version
39
 
                foreach method [glob $upgrade_dir/$version/*] {
40
 
                        regexp \[^\/\]*$ $method method
41
 
                        foreach file [glob $upgrade_dir/$version/$method/*] {
42
 
                                regexp (\[^\/\]*)\.tar\.gz$ $file dummy name
43
 
 
44
 
                                cleanup $testdir NULL 1
45
 
                                #puts  "$upgrade_dir/$version/$method/$name.tar.gz"
46
 
                                set curdir [pwd]
47
 
                                cd $testdir
48
 
                                set tarfd [open "|tar xf -" w]
49
 
                                cd $curdir
50
 
 
51
 
                                catch {exec gunzip -c "$upgrade_dir/$version/$method/$name.tar.gz" >@$tarfd}
52
 
                                close $tarfd
53
 
 
54
 
                                set f [open $testdir/$name.tcldump {RDWR CREAT}]
55
 
                                close $f
56
 
 
57
 
                                # It may seem suboptimal to exec a separate
58
 
                                # tclsh for each subtest, but this is
59
 
                                # necessary to keep the testing process
60
 
                                # from consuming a tremendous amount of
61
 
                                # memory.
62
 
                                if { [file exists $testdir/$name-le.db] } {
63
 
                                        set ret [catch {exec $tclsh_path\
64
 
                                            << "source $test_path/test.tcl;\
65
 
                                            _upgrade_test $testdir $version\
66
 
                                            $method\
67
 
                                            $name le"} message]
68
 
                                        puts $message
69
 
                                        if { $ret != 0 } {
70
 
                                                #exit
71
 
                                        }
72
 
                                }
73
 
 
74
 
                                if { [file exists $testdir/$name-be.db] } {
75
 
                                        set ret [catch {exec $tclsh_path\
76
 
                                            << "source $test_path/test.tcl;\
77
 
                                            _upgrade_test $testdir $version\
78
 
                                            $method\
79
 
                                            $name be"} message]
80
 
                                        puts $message
81
 
                                        if { $ret != 0 } {
82
 
                                                #exit
83
 
                                        }
84
 
                                }
85
 
 
86
 
                                set ret [catch {exec $tclsh_path\
87
 
                                    << "source $test_path/test.tcl;\
88
 
                                    _db_load_test $testdir $version $method\
89
 
                                    $name"} message]
90
 
                                        puts $message
91
 
                                if { $ret != 0 } {
92
 
                                        #exit
93
 
                                }
94
 
 
95
 
                        }
96
 
                }
97
 
        }
98
 
        set upgrade_dir $saved_upgrade_dir
99
 
 
100
 
        # Don't provide a return value.
101
 
        return
102
 
}
103
 
 
104
 
proc _upgrade_test { temp_dir version method file endianness } {
105
 
        source include.tcl
106
 
        global errorInfo
107
 
 
108
 
        puts "Upgrade: $version $method $file $endianness"
109
 
 
110
 
        set ret [berkdb upgrade "$temp_dir/$file-$endianness.db"]
111
 
        error_check_good dbupgrade $ret 0
112
 
 
113
 
        error_check_good dbupgrade_verify [verify_dir $temp_dir "" 0 0 1] 0
114
 
 
115
 
        upgrade_dump "$temp_dir/$file-$endianness.db" "$temp_dir/temp.dump"
116
 
 
117
 
        error_check_good "Upgrade diff.$endianness: $version $method $file" \
118
 
            [filecmp "$temp_dir/$file.tcldump" "$temp_dir/temp.dump"] 0
119
 
}
120
 
 
121
 
proc _db_load_test { temp_dir version method file } {
122
 
        source include.tcl
123
 
        global errorInfo
124
 
 
125
 
        puts "db_load: $version $method $file"
126
 
 
127
 
        set ret [catch \
128
 
            {exec $util_path/db_load -f "$temp_dir/$file.dump" \
129
 
            "$temp_dir/upgrade.db"} message]
130
 
        error_check_good \
131
 
            "Upgrade load: $version $method $file $message" $ret 0
132
 
 
133
 
        upgrade_dump "$temp_dir/upgrade.db" "$temp_dir/temp.dump"
134
 
 
135
 
        error_check_good "Upgrade diff.1.1: $version $method $file" \
136
 
            [filecmp "$temp_dir/$file.tcldump" "$temp_dir/temp.dump"] 0
137
 
}
138
 
 
139
 
proc gen_upgrade { dir } {
140
 
        global gen_upgrade
141
 
        global upgrade_dir
142
 
        global upgrade_be
143
 
        global upgrade_method
144
 
        global upgrade_name
145
 
        global num_test
146
 
        global parms
147
 
        source ./include.tcl
148
 
 
149
 
        set gen_upgrade 1
150
 
        set upgrade_dir $dir
151
 
 
152
 
        foreach i "btree rbtree hash recno rrecno frecno queue queueext" {
153
 
                puts "Running $i tests"
154
 
                set upgrade_method $i
155
 
                set start 1
156
 
                for { set j $start } { $j <= $num_test(test) } { incr j } {
157
 
                        set upgrade_name [format "test%03d" $j]
158
 
                        if { [info exists parms($upgrade_name)] != 1 } {
159
 
                                continue
160
 
                        }
161
 
 
162
 
                        foreach upgrade_be { 0 1 } {
163
 
                                if [catch {exec $tclsh_path \
164
 
                                    << "source $test_path/test.tcl;\
165
 
                                    global gen_upgrade upgrade_be;\
166
 
                                    global upgrade_method upgrade_name;\
167
 
                                    set gen_upgrade 1;\
168
 
                                    set upgrade_be $upgrade_be;\
169
 
                                    set upgrade_method $upgrade_method;\
170
 
                                    set upgrade_name $upgrade_name;\
171
 
                                    run_method -$i $j $j"} res] {
172
 
                                        puts "FAIL: $upgrade_name $i"
173
 
                                }
174
 
                                puts $res
175
 
                                cleanup $testdir NULL 1
176
 
                        }
177
 
                }
178
 
        }
179
 
        set gen_upgrade 0
180
 
}
181
 
 
182
 
proc upgrade_dump { database file {stripnulls 0} } {
183
 
        global errorInfo
184
 
 
185
 
        set db [berkdb open $database]
186
 
        set dbc [$db cursor]
187
 
 
188
 
        set f [open $file w+]
189
 
        fconfigure $f -encoding binary -translation binary
190
 
 
191
 
        #
192
 
        # Get a sorted list of keys
193
 
        #
194
 
        set key_list ""
195
 
        set pair [$dbc get -first]
196
 
 
197
 
        while { 1 } {
198
 
                if { [llength $pair] == 0 } {
199
 
                        break
200
 
                }
201
 
                set k [lindex [lindex $pair 0] 0]
202
 
                lappend key_list $k
203
 
                set pair [$dbc get -next]
204
 
        }
205
 
 
206
 
        # Discard duplicated keys;  we now have a key for each
207
 
        # duplicate, not each unique key, and we don't want to get each
208
 
        # duplicate multiple times when we iterate over key_list.
209
 
        set uniq_keys ""
210
 
        foreach key $key_list {
211
 
                if { [info exists existence_list($key)] == 0 } {
212
 
                        lappend uniq_keys $key
213
 
                }
214
 
                set existence_list($key) 1
215
 
        }
216
 
        set key_list $uniq_keys
217
 
 
218
 
        set key_list [lsort -command _comp $key_list]
219
 
 
220
 
        #
221
 
        # Get the data for each key
222
 
        #
223
 
        set i 0
224
 
        foreach key $key_list {
225
 
                set pair [$dbc get -set $key]
226
 
                if { $stripnulls != 0 } {
227
 
                        # the Tcl interface to db versions before 3.X
228
 
                        # added nulls at the end of all keys and data, so
229
 
                        # we provide functionality to strip that out.
230
 
                        set key [strip_null $key]
231
 
                }
232
 
                set data_list {}
233
 
                catch { while { [llength $pair] != 0 } {
234
 
                        set data [lindex [lindex $pair 0] 1]
235
 
                        if { $stripnulls != 0 } {
236
 
                                set data [strip_null $data]
237
 
                        }
238
 
                        lappend data_list [list $data]
239
 
                        set pair [$dbc get -nextdup]
240
 
                } }
241
 
                #lsort -command _comp data_list
242
 
                set data_list [lsort -command _comp $data_list]
243
 
                puts -nonewline $f [binary format i [string length $key]]
244
 
                puts -nonewline $f $key
245
 
                puts -nonewline $f [binary format i [llength $data_list]]
246
 
                for { set j 0 } { $j < [llength $data_list] } { incr j } {
247
 
                        puts -nonewline $f [binary format i [string length [concat [lindex $data_list $j]]]]
248
 
                        puts -nonewline $f [concat [lindex $data_list $j]]
249
 
                }
250
 
                if { [llength $data_list] == 0 } {
251
 
                        puts "WARNING: zero-length data list"
252
 
                }
253
 
                incr i
254
 
        }
255
 
 
256
 
        close $f
257
 
        error_check_good upgrade_dump_c_close [$dbc close] 0
258
 
        error_check_good upgrade_dump_db_close [$db close] 0
259
 
}
260
 
 
261
 
proc _comp { a b } {
262
 
        if { 0 } {
263
 
        # XXX
264
 
                set a [strip_null [concat $a]]
265
 
                set b [strip_null [concat $b]]
266
 
                #return [expr [concat $a] < [concat $b]]
267
 
        } else {
268
 
                set an [string first "\0" $a]
269
 
                set bn [string first "\0" $b]
270
 
 
271
 
                if { $an != -1 } {
272
 
                        set a [string range $a 0 [expr $an - 1]]
273
 
                }
274
 
                if { $bn != -1 } {
275
 
                        set b [string range $b 0 [expr $bn - 1]]
276
 
                }
277
 
        }
278
 
        #puts "$a $b"
279
 
        return [string compare $a $b]
280
 
}
281
 
 
282
 
proc strip_null { str } {
283
 
        set len [string length $str]
284
 
        set last [expr $len - 1]
285
 
 
286
 
        set termchar [string range $str $last $last]
287
 
        if { [string compare $termchar \0] == 0 } {
288
 
                set ret [string range $str 0 [expr $last - 1]]
289
 
        } else {
290
 
                set ret $str
291
 
        }
292
 
 
293
 
        return $ret
294
 
}