← 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/test015.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/test015.tcl
1
 
# See the file LICENSE for redistribution information.
2
 
#
3
 
# Copyright (c) 1996-2002
4
 
#       Sleepycat Software.  All rights reserved.
5
 
#
6
 
# $Id$
7
 
#
8
 
# TEST  test015
9
 
# TEST  Partial put test
10
 
# TEST          Partial put test where the key does not initially exist.
11
 
proc test015 { method {nentries 7500} { start 0 } args } {
12
 
        global fixed_len testdir
13
 
 
14
 
        set low_range 50
15
 
        set mid_range 100
16
 
        set high_range 1000
17
 
 
18
 
        if { [is_fixed_length $method] } {
19
 
                set low_range [expr $fixed_len/2 - 2]
20
 
                set mid_range [expr $fixed_len/2]
21
 
                set high_range $fixed_len
22
 
        }
23
 
 
24
 
        set t_table {
25
 
                { 1 { 1 1 1 } }
26
 
                { 2 { 1 1 5 } }
27
 
                { 3 { 1 1 $low_range } }
28
 
                { 4 { 1 $mid_range 1 } }
29
 
                { 5 { $mid_range $high_range 5 } }
30
 
                { 6 { 1 $mid_range $low_range } }
31
 
        }
32
 
 
33
 
        puts "Test015: \
34
 
            $method ($args) $nentries equal key/data pairs, partial put test"
35
 
        test015_init
36
 
        if { $start == 0 } {
37
 
                set start { 1 2 3 4 5 6 }
38
 
        }
39
 
        foreach entry $t_table {
40
 
                set this [lindex $entry 0]
41
 
                if { [lsearch $start $this] == -1 } {
42
 
                        continue
43
 
                }
44
 
                puts -nonewline "$this: "
45
 
                eval [concat test015_body $method [lindex $entry 1] \
46
 
                    $nentries $args]
47
 
                set eindex [lsearch -exact $args "-env"]
48
 
                if { $eindex != -1 } {
49
 
                        incr eindex
50
 
                        set env [lindex $args $eindex]
51
 
                        set testdir [get_home $env]
52
 
                }
53
 
puts "Verifying testdir $testdir"
54
 
 
55
 
                error_check_good verify [verify_dir $testdir "\tTest015.e: "] 0
56
 
        }
57
 
}
58
 
 
59
 
proc test015_init { } {
60
 
        global rand_init
61
 
 
62
 
        berkdb srand $rand_init
63
 
}
64
 
 
65
 
proc test015_body { method off_low off_hi rcount {nentries 10000} args } {
66
 
        global dvals
67
 
        global fixed_len
68
 
        global testdir
69
 
        source ./include.tcl
70
 
 
71
 
        set args [convert_args $method $args]
72
 
        set omethod [convert_method $method]
73
 
 
74
 
        set checkfunc test015.check
75
 
 
76
 
        if { [is_fixed_length $method] && \
77
 
                [string compare $omethod "-recno"] == 0} {
78
 
                # is fixed recno method
79
 
                set checkfunc test015.check
80
 
        }
81
 
 
82
 
        puts "Put $rcount strings random offsets between $off_low and $off_hi"
83
 
 
84
 
        # Create the database and open the dictionary
85
 
        set txnenv 0
86
 
        set eindex [lsearch -exact $args "-env"]
87
 
        #
88
 
        # If we are using an env, then testfile should just be the db name.
89
 
        # Otherwise it is the test directory and the name.
90
 
        if { $eindex == -1 } {
91
 
                set testfile $testdir/test015.db
92
 
                set env NULL
93
 
        } else {
94
 
                set testfile test015.db
95
 
                incr eindex
96
 
                set env [lindex $args $eindex]
97
 
                set txnenv [is_txnenv $env]
98
 
                if { $txnenv == 1 } {
99
 
                        append args " -auto_commit "
100
 
                        #
101
 
                        # If we are using txns and running with the
102
 
                        # default, set the default down a bit.
103
 
                        #
104
 
                        if { $nentries > 5000 } {
105
 
                                set nentries 100
106
 
                        }
107
 
                }
108
 
                set testdir [get_home $env]
109
 
        }
110
 
        set retdir $testdir
111
 
        set t1 $testdir/t1
112
 
        set t2 $testdir/t2
113
 
        set t3 $testdir/t3
114
 
        cleanup $testdir $env
115
 
 
116
 
        set db [eval {berkdb_open \
117
 
             -create -mode 0644} $args {$omethod $testfile}]
118
 
        error_check_good dbopen [is_valid_db $db] TRUE
119
 
 
120
 
        set pflags ""
121
 
        set gflags ""
122
 
        set txn ""
123
 
        set count 0
124
 
 
125
 
        puts "\tTest015.a: put/get loop for $nentries entries"
126
 
 
127
 
        # Here is the loop where we put and get each key/data pair
128
 
        # Each put is a partial put of a record that does not exist.
129
 
        set did [open $dict]
130
 
        while { [gets $did str] != -1 && $count < $nentries } {
131
 
                if { [is_record_based $method] == 1 } {
132
 
                        if { [string length $str] > $fixed_len } {
133
 
                                continue
134
 
                        }
135
 
                        set key [expr $count + 1]
136
 
                } else {
137
 
                        set key $str
138
 
                }
139
 
 
140
 
                if { 0 } {
141
 
                        set data [replicate $str $rcount]
142
 
                        set off [ berkdb random_int $off_low $off_hi ]
143
 
                        set offn [expr $off + 1]
144
 
                        if { [is_fixed_length $method] && \
145
 
                            [expr [string length $data] + $off] >= $fixed_len} {
146
 
                            set data [string range $data 0 [expr $fixed_len-$offn]]
147
 
                        }
148
 
                        set dvals($key) [partial_shift $data $off right]
149
 
                } else {
150
 
                        set data [chop_data $method [replicate $str $rcount]]
151
 
 
152
 
                        # This is a hack.  In DB we will store the records with
153
 
                        # some padding, but these will get lost if we just return
154
 
                        # them in TCL.  As a result, we're going to have to hack
155
 
                        # get to check for 0 padding and return a list consisting
156
 
                        # of the number of 0's and the actual data.
157
 
                        set off [ berkdb random_int $off_low $off_hi ]
158
 
 
159
 
                        # There is no string concatenation function in Tcl
160
 
                        # (although there is one in TclX), so we have to resort
161
 
                        # to this hack. Ugh.
162
 
                        set slen [string length $data]
163
 
                        if {[is_fixed_length $method] && \
164
 
                            $slen > $fixed_len - $off} {
165
 
                                set $slen [expr $fixed_len - $off]
166
 
                        }
167
 
                        set a "a"
168
 
                        set dvals($key) [pad_data \
169
 
                            $method [eval "binary format x$off$a$slen" {$data}]]
170
 
                }
171
 
                if {[is_fixed_length $method] && \
172
 
                    [string length $data] > ($fixed_len - $off)} {
173
 
                    set slen [expr $fixed_len - $off]
174
 
                    set data [eval "binary format a$slen" {$data}]
175
 
                }
176
 
                if { $txnenv == 1 } {
177
 
                        set t [$env txn]
178
 
                        error_check_good txn [is_valid_txn $t $env] TRUE
179
 
                        set txn "-txn $t"
180
 
                }
181
 
                set ret [eval {$db put} $txn \
182
 
                    {-partial [list $off [string length $data]] $key $data}]
183
 
                error_check_good put $ret 0
184
 
                if { $txnenv == 1 } {
185
 
                        error_check_good txn [$t commit] 0
186
 
                }
187
 
 
188
 
                incr count
189
 
        }
190
 
        close $did
191
 
 
192
 
        # Now make sure that everything looks OK
193
 
        puts "\tTest015.b: check entire file contents"
194
 
        if { $txnenv == 1 } {
195
 
                set t [$env txn]
196
 
                error_check_good txn [is_valid_txn $t $env] TRUE
197
 
                set txn "-txn $t"
198
 
        }
199
 
        dump_file $db $txn $t1 $checkfunc
200
 
        if { $txnenv == 1 } {
201
 
                error_check_good txn [$t commit] 0
202
 
        }
203
 
        error_check_good db_close [$db close] 0
204
 
 
205
 
        # Now compare the keys to see if they match the dictionary (or ints)
206
 
        if { [is_record_based $method] == 1 } {
207
 
                set oid [open $t2 w]
208
 
                for {set i 1} {$i <= $nentries} {set i [incr i]} {
209
 
                        puts $oid $i
210
 
                }
211
 
                close $oid
212
 
                filesort $t2 $t3
213
 
                file rename -force $t3 $t2
214
 
                filesort $t1 $t3
215
 
        } else {
216
 
                set q q
217
 
                filehead $nentries $dict $t3
218
 
                filesort $t3 $t2
219
 
                filesort $t1 $t3
220
 
        }
221
 
 
222
 
        error_check_good Test015:diff($t3,$t2) \
223
 
            [filecmp $t3 $t2] 0
224
 
 
225
 
        puts "\tTest015.c: close, open, and dump file"
226
 
        # Now, reopen the file and run the last test again.
227
 
        open_and_dump_file $testfile $env $t1 \
228
 
            $checkfunc dump_file_direction "-first" "-next"
229
 
 
230
 
        if { [string compare $omethod "-recno"] != 0 } {
231
 
                filesort $t1 $t3
232
 
        }
233
 
 
234
 
        error_check_good Test015:diff($t3,$t2) \
235
 
            [filecmp $t3 $t2] 0
236
 
 
237
 
        # Now, reopen the file and run the last test again in the
238
 
        # reverse direction.
239
 
        puts "\tTest015.d: close, open, and dump file in reverse direction"
240
 
        open_and_dump_file $testfile $env $t1 \
241
 
            $checkfunc dump_file_direction "-last" "-prev"
242
 
 
243
 
        if { [string compare $omethod "-recno"] != 0 } {
244
 
                filesort $t1 $t3
245
 
        }
246
 
 
247
 
        error_check_good Test015:diff($t3,$t2) \
248
 
            [filecmp $t3 $t2] 0
249
 
 
250
 
        unset dvals
251
 
}
252
 
 
253
 
# Check function for test015; keys and data are identical
254
 
proc test015.check { key data } {
255
 
        global dvals
256
 
 
257
 
        error_check_good key"$key"_exists [info exists dvals($key)] 1
258
 
        binary scan $data "c[string length $data]" a
259
 
        binary scan $dvals($key) "c[string length $dvals($key)]" b
260
 
        error_check_good "mismatch on padding for key $key" $a $b
261
 
}
262
 
 
263
 
proc test015.fixed.check { key data } {
264
 
        global dvals
265
 
        global fixed_len
266
 
 
267
 
        error_check_good key"$key"_exists [info exists dvals($key)] 1
268
 
        if { [string length $data] > $fixed_len } {
269
 
                error_check_bad \
270
 
                    "data length:[string length $data] \
271
 
                    for fixed:$fixed_len" 1 1
272
 
        }
273
 
        puts "$data : $dvals($key)"
274
 
        error_check_good compare_data($data,$dvals($key) \
275
 
            $dvals($key) $data
276
 
}