← 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/test042.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/test042.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  test042
9
 
# TEST  Concurrent Data Store test (CDB)
10
 
# TEST
11
 
# TEST  Multiprocess DB test; verify that locking is working for the
12
 
# TEST  concurrent access method product.
13
 
# TEST
14
 
# TEST  Use the first "nentries" words from the dictionary.  Insert each with
15
 
# TEST  self as key and a fixed, medium length data string.  Then fire off
16
 
# TEST  multiple processes that bang on the database.  Each one should try to
17
 
# TEST  read and write random keys.  When they rewrite, they'll append their
18
 
# TEST  pid to the data string (sometimes doing a rewrite sometimes doing a
19
 
# TEST  partial put).  Some will use cursors to traverse through a few keys
20
 
# TEST  before finding one to write.
21
 
 
22
 
proc test042 { method {nentries 1000} args } {
23
 
        global encrypt
24
 
 
25
 
        #
26
 
        # If we are using an env, then skip this test.  It needs its own.
27
 
        set eindex [lsearch -exact $args "-env"]
28
 
        if { $eindex != -1 } {
29
 
                incr eindex
30
 
                set env [lindex $args $eindex]
31
 
                puts "Test042 skipping for env $env"
32
 
                return
33
 
        }
34
 
 
35
 
        set args [convert_args $method $args]
36
 
        if { $encrypt != 0 } {
37
 
                puts "Test042 skipping for security"
38
 
                return
39
 
        }
40
 
        test042_body $method $nentries 0 $args
41
 
        test042_body $method $nentries 1 $args
42
 
}
43
 
 
44
 
proc test042_body { method nentries alldb args } {
45
 
        source ./include.tcl
46
 
 
47
 
        if { $alldb } {
48
 
                set eflag "-cdb -cdb_alldb"
49
 
        } else {
50
 
                set eflag "-cdb"
51
 
        }
52
 
        puts "Test042: CDB Test ($eflag) $method $nentries"
53
 
 
54
 
        # Set initial parameters
55
 
        set do_exit 0
56
 
        set iter 10000
57
 
        set procs 5
58
 
 
59
 
        # Process arguments
60
 
        set oargs ""
61
 
        for { set i 0 } { $i < [llength $args] } {incr i} {
62
 
                switch -regexp -- [lindex $args $i] {
63
 
                        -dir    { incr i; set testdir [lindex $args $i] }
64
 
                        -iter   { incr i; set iter [lindex $args $i] }
65
 
                        -procs  { incr i; set procs [lindex $args $i] }
66
 
                        -exit   { set do_exit 1 }
67
 
                        default { append oargs " " [lindex $args $i] }
68
 
                }
69
 
        }
70
 
 
71
 
        # Create the database and open the dictionary
72
 
        set testfile test042.db
73
 
        set t1 $testdir/t1
74
 
        set t2 $testdir/t2
75
 
        set t3 $testdir/t3
76
 
 
77
 
        env_cleanup $testdir
78
 
 
79
 
        set env [eval {berkdb_env -create} $eflag -home $testdir]
80
 
        error_check_good dbenv [is_valid_env $env] TRUE
81
 
 
82
 
        # Env is created, now set up database
83
 
        test042_dbinit $env $nentries $method $oargs $testfile 0
84
 
        if { $alldb } {
85
 
                for { set i 1 } {$i < $procs} {incr i} {
86
 
                        test042_dbinit $env $nentries $method $oargs \
87
 
                            $testfile $i
88
 
                }
89
 
        }
90
 
 
91
 
        # Remove old mpools and Open/create the lock and mpool regions
92
 
        error_check_good env:close:$env [$env close] 0
93
 
        set ret [berkdb envremove -home $testdir]
94
 
        error_check_good env_remove $ret 0
95
 
 
96
 
        set env [eval {berkdb_env -create} $eflag -home $testdir]
97
 
        error_check_good dbenv [is_valid_widget $env env] TRUE
98
 
 
99
 
        if { $do_exit == 1 } {
100
 
                return
101
 
        }
102
 
 
103
 
        # Now spawn off processes
104
 
        berkdb debug_check
105
 
        puts "\tTest042.b: forking off $procs children"
106
 
        set pidlist {}
107
 
 
108
 
        for { set i 0 } {$i < $procs} {incr i} {
109
 
                if { $alldb } {
110
 
                        set tf $testfile$i
111
 
                } else {
112
 
                        set tf ${testfile}0
113
 
                }
114
 
                puts "exec $tclsh_path $test_path/wrap.tcl \
115
 
                    mdbscript.tcl $testdir/test042.$i.log \
116
 
                    $method $testdir $tf $nentries $iter $i $procs &"
117
 
                set p [exec $tclsh_path $test_path/wrap.tcl \
118
 
                    mdbscript.tcl $testdir/test042.$i.log $method \
119
 
                    $testdir $tf $nentries $iter $i $procs &]
120
 
                lappend pidlist $p
121
 
        }
122
 
        puts "Test042: $procs independent processes now running"
123
 
        watch_procs $pidlist 
124
 
 
125
 
        # Check for test failure
126
 
        set e [eval findfail [glob $testdir/test042.*.log]]
127
 
        error_check_good "FAIL: error message(s) in log files" $e 0
128
 
 
129
 
        # Test is done, blow away lock and mpool region
130
 
        reset_env $env
131
 
}
132
 
 
133
 
# If we are renumbering, then each time we delete an item, the number of
134
 
# items in the file is temporarily decreased, so the highest record numbers
135
 
# do not exist.  To make sure this doesn't happen, we never generate the
136
 
# highest few record numbers as keys.
137
 
#
138
 
# For record-based methods, record numbers begin at 1, while for other keys,
139
 
# we begin at 0 to index into an array.
140
 
proc rand_key { method nkeys renum procs} {
141
 
        if { $renum == 1 } {
142
 
                return [berkdb random_int 1 [expr $nkeys - $procs]]
143
 
        } elseif { [is_record_based $method] == 1 } {
144
 
                return [berkdb random_int 1 $nkeys]
145
 
        } else {
146
 
                return [berkdb random_int 0 [expr $nkeys - 1]]
147
 
        }
148
 
}
149
 
 
150
 
proc test042_dbinit { env nentries method oargs tf ext } {
151
 
        global datastr
152
 
        source ./include.tcl
153
 
 
154
 
        set omethod [convert_method $method]
155
 
        set db [eval {berkdb_open -env $env -create \
156
 
            -mode 0644 $omethod} $oargs {$tf$ext}]
157
 
        error_check_good dbopen [is_valid_db $db] TRUE
158
 
 
159
 
        set did [open $dict]
160
 
 
161
 
        set pflags ""
162
 
        set gflags ""
163
 
        set txn ""
164
 
        set count 0
165
 
 
166
 
        # Here is the loop where we put each key/data pair
167
 
        puts "\tTest042.a: put loop $tf$ext"
168
 
        while { [gets $did str] != -1 && $count < $nentries } {
169
 
                if { [is_record_based $method] == 1 } {
170
 
                        set key [expr $count + 1]
171
 
                } else {
172
 
                        set key $str
173
 
                }
174
 
                set ret [eval {$db put} \
175
 
                    $txn $pflags {$key [chop_data $method $datastr]}]
176
 
                error_check_good put:$db $ret 0
177
 
                incr count
178
 
        }
179
 
        close $did
180
 
        error_check_good close:$db [$db close] 0
181
 
}