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
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
|
# See the file LICENSE for redistribution information.
#
# Copyright (c) 1999-2009 Oracle. All rights reserved.
#
# $Id$
source ./include.tcl
global upgrade_dir
# set upgrade_dir "$test_path/upgrade_test"
set upgrade_dir "$test_path/upgrade/databases"
global gen_upgrade
set gen_upgrade 0
global gen_dump
set gen_dump 0
global gen_chksum
set gen_chksum 0
global gen_upgrade_log
set gen_upgrade_log 0
global upgrade_dir
global upgrade_be
global upgrade_method
global upgrade_name
proc upgrade { { archived_test_loc "DEFAULT" } } {
source ./include.tcl
global test_names
global upgrade_dir
global tcl_platform
global saved_logvers
set saved_upgrade_dir $upgrade_dir
# Identify endianness of the machine running upgrade.
if { [big_endian] == 1 } {
set myendianness be
} else {
set myendianness le
}
set e $tcl_platform(byteOrder)
if { [file exists $archived_test_loc/logversion] == 1 } {
set fd [open $archived_test_loc/logversion r]
set saved_logvers [read $fd]
close $fd
} else {
puts "Old log version number must be available \
in $archived_test_loc/logversion"
return
}
fileremove -f UPGRADE.OUT
set o [open UPGRADE.OUT a]
puts -nonewline $o "Upgrade test started at: "
puts $o [clock format [clock seconds] -format "%H:%M %D"]
puts $o [berkdb version -string]
puts $o "Testing $e files"
puts -nonewline "Upgrade test started at: "
puts [clock format [clock seconds] -format "%H:%M %D"]
puts [berkdb version -string]
puts "Testing $e files"
if { $archived_test_loc == "DEFAULT" } {
puts $o "Using default archived databases in $upgrade_dir."
puts "Using default archived databases in $upgrade_dir."
} else {
set upgrade_dir $archived_test_loc
puts $o "Using archived databases in $upgrade_dir."
puts "Using archived databases in $upgrade_dir."
}
close $o
foreach version [glob $upgrade_dir/*] {
if { [string first CVS $version] != -1 } { continue }
regexp \[^\/\]*$ $version version
# Test only files where the endianness of the db matches
# the endianness of the test platform. These are the
# meaningful tests:
# 1. File generated on le, tested on le
# 2. File generated on be, tested on be
# 3. Byte-swapped file generated on le, tested on be
# 4. Byte-swapped file generated on be, tested on le
#
set dbendianness [string range $version end-1 end]
if { [string compare $myendianness $dbendianness] != 0 } {
puts "Skipping test of $version \
on $myendianness platform."
} else {
set release [string trim $version -lbe]
set o [open UPGRADE.OUT a]
puts $o "Files created on release $release"
close $o
puts "Files created on release $release"
foreach method [glob $upgrade_dir/$version/*] {
regexp \[^\/\]*$ $method method
set o [open UPGRADE.OUT a]
puts $o "\nTesting $method files"
close $o
puts "\tTesting $method files"
foreach file [lsort -dictionary \
[glob -nocomplain \
$upgrade_dir/$version/$method/*]] {
regexp (\[^\/\]*)\.tar\.gz$ \
$file dummy name
cleanup $testdir NULL 1
set curdir [pwd]
cd $testdir
set tarfd [open "|tar xf -" w]
cd $curdir
catch {exec gunzip -c \
"$upgrade_dir/$version/$method/$name.tar.gz" \
>@$tarfd}
close $tarfd
set f [open $testdir/$name.tcldump \
{RDWR CREAT}]
close $f
# We exec a separate tclsh for each
# separate subtest to keep the
# testing process from consuming a
# tremendous amount of memory.
#
# First we test the .db files.
if { [file exists \
$testdir/$name-$myendianness.db] } {
if { [catch {exec $tclsh_path \
<< "source \
$test_path/test.tcl;\
_upgrade_test $testdir \
$version $method $name \
$myendianness" >>& \
UPGRADE.OUT } message] } {
set o [open \
UPGRADE.OUT a]
puts $o "FAIL: $message"
close $o
}
if { [catch {exec $tclsh_path\
<< "source \
$test_path/test.tcl;\
_db_load_test $testdir \
$version $method $name" >>&\
UPGRADE.OUT } message] } {
set o [open \
UPGRADE.OUT a]
puts $o "FAIL: $message"
close $o
}
}
# Then we test log files.
if { [file exists \
$testdir/$name.prlog] } {
if { [catch {exec $tclsh_path \
<< "source \
$test_path/test.tcl;\
global saved_logvers;\
set saved_logvers \
$saved_logvers;\
_log_test $testdir \
$release $method \
$name" >>& \
UPGRADE.OUT } message] } {
set o [open \
UPGRADE.OUT a]
puts $o "FAIL: $message"
close $o
}
}
# Then we test any .dmp files. Move
# the saved file to the current working
# directory. Run the test locally.
# Compare the dumps; they should match.
if { [file exists $testdir/$name.dmp] } {
file rename -force \
$testdir/$name.dmp $name.dmp
foreach test $test_names(plat) {
eval $test $method
}
# Discard lines that can differ.
discardline $name.dmp \
TEMPFILE "db_pagesize="
file copy -force \
TEMPFILE $name.dmp
discardline $testdir/$test.dmp \
TEMPFILE "db_pagesize="
file copy -force \
TEMPFILE $testdir/$test.dmp
error_check_good compare_dump \
[filecmp $name.dmp \
$testdir/$test.dmp] 0
fileremove $name.dmp
}
}
}
}
}
set upgrade_dir $saved_upgrade_dir
set o [open UPGRADE.OUT a]
puts -nonewline $o "Completed at: "
puts $o [clock format [clock seconds] -format "%H:%M %D"]
close $o
puts -nonewline "Completed at: "
puts [clock format [clock seconds] -format "%H:%M %D"]
# Don't provide a return value.
return
}
proc _upgrade_test { temp_dir version method file endianness } {
source include.tcl
global errorInfo
global passwd
global encrypt
puts "Upgrade: $version $method $file $endianness"
# Check whether we're working with an encrypted file.
if { [string match c-* $file] } {
set encrypt 1
}
# Open the database prior to upgrading. If it fails,
# it should fail with the DB_OLDVERSION message.
set encargs ""
set upgradeargs ""
if { $encrypt == 1 } {
set encargs " -encryptany $passwd "
set upgradeargs " -P $passwd "
}
if { [catch \
{ set db [eval {berkdb open} $encargs \
$temp_dir/$file-$endianness.db] } res] } {
error_check_good old_version [is_substr $res DB_OLDVERSION] 1
} else {
error_check_good db_close [$db close] 0
}
# Now upgrade the database.
set ret [catch {eval exec {$util_path/db_upgrade} $upgradeargs \
"$temp_dir/$file-$endianness.db" } message]
error_check_good dbupgrade $ret 0
error_check_good dbupgrade_verify [verify_dir $temp_dir "" 0 0 1] 0
upgrade_dump "$temp_dir/$file-$endianness.db" "$temp_dir/temp.dump"
error_check_good "Upgrade diff.$endianness: $version $method $file" \
[filecmp "$temp_dir/$file.tcldump" "$temp_dir/temp.dump"] 0
}
proc _db_load_test { temp_dir version method file } {
source include.tcl
global errorInfo
puts "Db_load: $version $method $file"
set ret [catch \
{exec $util_path/db_load -f "$temp_dir/$file.dump" \
"$temp_dir/upgrade.db"} message]
error_check_good \
"Upgrade load: $version $method $file $message" $ret 0
upgrade_dump "$temp_dir/upgrade.db" "$temp_dir/temp.dump"
error_check_good "Upgrade diff.1.1: $version $method $file" \
[filecmp "$temp_dir/$file.tcldump" "$temp_dir/temp.dump"] 0
}
proc _log_test { temp_dir release method file } {
source ./include.tcl
global saved_logvers
global passwd
puts "Check log file: $temp_dir $release $method $file"
# Get log version number of current system
set env [berkdb_env -create -log -home $testdir]
error_check_good is_valid_env [is_valid_env $env] TRUE
set current_logvers [get_log_vers $env]
error_check_good env_close [$env close] 0
error_check_good env_remove [berkdb envremove -home $testdir] 0
# Rename recd001-x-log.000000000n to log.000000000n.
set logfiles [glob -nocomplain $temp_dir/*log.0*]
foreach logfile $logfiles {
set logname [string replace $logfile 0 \
[string last - $logfile]]
file rename -force $logfile $temp_dir/$logname
}
# Use db_printlog to dump the logs. If the current log file
# version is greater than the saved log file version, the log
# files are expected to be unreadable. If the log file is
# readable, check that the current printlog dump matches the
# archived printlog.
#
set ret [catch {exec $util_path/db_printlog -h $temp_dir \
> $temp_dir/logs.prlog} message]
if { [is_substr $message "magic number"] } {
# The failure is probably due to encryption, try
# crypto printlog.
set ret [catch {exec $util_path/db_printlog -h $temp_dir \
-P $passwd > $temp_dir/logs.prlog} message]
if { $ret == 1 } {
# If the failure is because of a historic
# log version, that's okay.
if { $current_logvers <= $saved_logvers } {
puts "db_printlog failed: $message"
}
}
}
# Log versions prior to 8 can only be read by their own version.
# Log versions of 8 or greater are readable by Berkeley DB 4.5
# or greater, but the output of printlog does not match unless
# the versions are identical.
#
# As of Berkeley DB 4.8, we'll only try to read back to log
# version 11, which came out with 4.4. Backwards compatibility
# now only extends back to 4.4 because of page changes.
#
set logoldver 11
if { $current_logvers > $saved_logvers &&\
$saved_logvers < $logoldver } {
error_check_good historic_log_version \
[is_substr $message "historic log version"] 1
} elseif { $current_logvers > $saved_logvers } {
error_check_good db_printlog:$message $ret 0
} elseif { $current_logvers == $saved_logvers } {
error_check_good db_printlog:$message $ret 0
# Compare logs.prlog and $file.prlog (should match)
error_check_good "Compare printlogs" [filecmp \
"$temp_dir/logs.prlog" "$temp_dir/$file.prlog"] 0
} elseif { $current_logvers < $saved_logvers } {
puts -nonewline "FAIL: current log version $current_logvers "
puts "cannot be less than saved log version $save_logvers."
}
}
proc gen_upgrade { dir { save_crypto 1 } { save_non_crypto 1 } } {
global gen_upgrade
global gen_upgrade_log
global gen_chksum
global gen_dump
global upgrade_dir
global upgrade_be
global upgrade_method
global upgrade_name
global valid_methods
global test_names
global parms
global encrypt
global passwd
source ./include.tcl
set upgrade_dir $dir
env_cleanup $testdir
fileremove -f GENERATE.OUT
set o [open GENERATE.OUT a]
puts -nonewline $o "Generating upgrade files. Started at: "
puts $o [clock format [clock seconds] -format "%H:%M %D"]
puts $o [berkdb version -string]
puts -nonewline "Generating upgrade files. Started at: "
puts [clock format [clock seconds] -format "%H:%M %D"]
puts [berkdb version -string]
close $o
# Create a file that contains the log version number.
# If necessary, create the directory to contain the file.
set env [berkdb_env -create -log -home $testdir]
error_check_good is_valid_env [is_valid_env $env] TRUE
if { [file exists $dir] == 0 } {
file mkdir $dir
}
set lv [open $dir/logversion w]
puts $lv [get_log_vers $env]
close $lv
error_check_good env_close [$env close] 0
# Generate test databases for each access method and endianness.
foreach method $valid_methods {
set o [open GENERATE.OUT a]
puts $o "\nGenerating $method files"
close $o
puts "\tGenerating $method files"
set upgrade_method $method
# We piggyback testing of dumped sequence files on upgrade
# testing because this is the only place that we ship files
# from one machine to another. Create files for both
# endiannesses, because who knows what platform we'll
# be testing on.
set gen_dump 1
foreach test $test_names(plat) {
set upgrade_name $test
foreach upgrade_be { 0 1 } {
eval $test $method
cleanup $testdir NULL
}
}
set gen_dump 0
#set test_names(test) ""
set gen_upgrade 1
foreach test $test_names(test) {
if { [info exists parms($test)] != 1 } {
continue
}
set o [open GENERATE.OUT a]
puts $o "\t\tGenerating files for $test"
close $o
puts "\t\tGenerating files for $test"
if { $save_non_crypto == 1 } {
set encrypt 0
foreach upgrade_be { 0 1 } {
set upgrade_name $test
if [catch {exec $tclsh_path \
<< "source $test_path/test.tcl;\
global gen_upgrade upgrade_be;\
global upgrade_method upgrade_name;\
global encrypt;\
set encrypt $encrypt;\
set gen_upgrade 1;\
set upgrade_be $upgrade_be;\
set upgrade_method $upgrade_method;\
set upgrade_name $upgrade_name;\
run_method -$method $test" \
>>& GENERATE.OUT} res] {
puts "FAIL: run_method \
$test $method"
}
cleanup $testdir NULL 1
}
# Save checksummed files for only one test.
# Checksumming should work in all or no cases.
set gen_chksum 1
foreach upgrade_be { 0 1 } {
set upgrade_name $test
if { $test == "test001" } {
if { [catch {exec $tclsh_path \
<< "source $test_path/test.tcl;\
global gen_upgrade;\
global upgrade_be;\
global upgrade_method;\
global upgrade_name;\
global encrypt gen_chksum;\
set encrypt $encrypt;\
set gen_upgrade 1;\
set gen_chksum 1;\
set upgrade_be $upgrade_be;\
set upgrade_method \
$upgrade_method;\
set upgrade_name \
$upgrade_name;\
run_method -$method $test \
0 1 stdout -chksum" \
>>& GENERATE.OUT} res] } {
puts "FAIL: run_method \
$test $method \
-chksum: $res"
}
cleanup $testdir NULL 1
}
}
set gen_chksum 0
}
# Save encrypted db's only of native endianness.
# Encrypted files are not portable across endianness.
if { $save_crypto == 1 } {
set upgrade_be [big_endian]
set encrypt 1
set upgrade_name $test
if [catch {exec $tclsh_path \
<< "source $test_path/test.tcl;\
global gen_upgrade upgrade_be;\
global upgrade_method upgrade_name;\
global encrypt passwd;\
set encrypt $encrypt;\
set passwd $passwd;\
set gen_upgrade 1;\
set upgrade_be $upgrade_be;\
set upgrade_method $upgrade_method;\
set upgrade_name $upgrade_name;\
run_secmethod $method $test" \
>>& GENERATE.OUT} res] {
puts "FAIL: run_secmethod \
$test $method"
}
cleanup $testdir NULL 1
}
}
set gen_upgrade 0
}
# Set upgrade_be to the native value so log files go to the
# right place.
set upgrade_be [big_endian]
# Generate log files.
set o [open GENERATE.OUT a]
puts $o "\tGenerating log files"
close $o
puts "\tGenerating log files"
set gen_upgrade_log 1
# Pass the global variables and their values to the new tclsh.
if { $save_non_crypto == 1 } {
set encrypt 0
if [catch {exec $tclsh_path << "source $test_path/test.tcl;\
global gen_upgrade_log upgrade_be upgrade_dir;\
global encrypt;\
set encrypt $encrypt;\
set gen_upgrade_log $gen_upgrade_log; \
set upgrade_be $upgrade_be;\
set upgrade_dir $upgrade_dir;\
run_recds" >>& GENERATE.OUT} res] {
puts "FAIL: run_recds: $res"
}
}
if { $save_crypto == 1 } {
set encrypt 1
if [catch {exec $tclsh_path << "source $test_path/test.tcl;\
global gen_upgrade_log upgrade_be upgrade_dir;\
global encrypt;\
set encrypt $encrypt;\
set gen_upgrade_log $gen_upgrade_log; \
set upgrade_be $upgrade_be;\
set upgrade_dir $upgrade_dir;\
run_recds " >>& GENERATE.OUT} res] {
puts "FAIL: run_recds with crypto: $res"
}
}
set gen_upgrade_log 0
set o [open GENERATE.OUT a]
puts -nonewline $o "Completed at: "
puts $o [clock format [clock seconds] -format "%H:%M %D"]
puts -nonewline "Completed at: "
puts [clock format [clock seconds] -format "%H:%M %D"]
close $o
}
proc save_upgrade_files { dir } {
global upgrade_dir
global upgrade_be
global upgrade_method
global upgrade_name
global gen_upgrade
global gen_upgrade_log
global gen_dump
global encrypt
global gen_chksum
global passwd
source ./include.tcl
set vers [berkdb version]
set maj [lindex $vers 0]
set min [lindex $vers 1]
# Is this machine big or little endian? We want to mark
# the test directories appropriately, since testing
# little-endian databases generated by a big-endian machine,
# and/or vice versa, is interesting.
if { [big_endian] } {
set myendianness be
} else {
set myendianness le
}
if { $upgrade_be == 1 } {
set version_dir "$myendianness-$maj.${min}be"
set en be
} else {
set version_dir "$myendianness-$maj.${min}le"
set en le
}
set dest $upgrade_dir/$version_dir/$upgrade_method
exec mkdir -p $dest
if { $gen_upgrade == 1 } {
# Save db files from test001 - testxxx.
set dbfiles [glob -nocomplain $dir/*.db]
set dumpflag ""
# Encrypted files are identified by the prefix "c-".
if { $encrypt == 1 } {
set upgrade_name c-$upgrade_name
set dumpflag " -P $passwd "
}
# Checksummed files are identified by the prefix "s-".
if { $gen_chksum == 1 } {
set upgrade_name s-$upgrade_name
}
foreach dbfile $dbfiles {
set basename [string range $dbfile \
[expr [string length $dir] + 1] end-3]
set newbasename $upgrade_name-$basename
# db_dump file
if { [catch {eval exec $util_path/db_dump -k $dumpflag \
$dbfile > $dir/$newbasename.dump} res] } {
puts "FAIL: $res"
}
# tcl_dump file
upgrade_dump $dbfile $dir/$newbasename.tcldump
# Rename dbfile and any dbq files.
file rename $dbfile $dir/$newbasename-$en.db
foreach dbq \
[glob -nocomplain $dir/__dbq.$basename.db.*] {
set s [string length $dir/__dbq.]
set newname [string replace $dbq $s \
[expr [string length $basename] + $s - 1] \
$newbasename-$en]
file rename $dbq $newname
}
set cwd [pwd]
cd $dir
catch {eval exec tar -cvf $dest/$newbasename.tar \
[glob $newbasename* __dbq.$newbasename-$en.db.*]}
catch {exec gzip -9v $dest/$newbasename.tar} res
cd $cwd
}
}
if { $gen_upgrade_log == 1 } {
# Save log files from recd tests.
set logfiles [glob -nocomplain $dir/log.*]
if { [llength $logfiles] > 0 } {
# More than one log.0000000001 file may be produced
# per recd test, so we generate unique names:
# recd001-0-log.0000000001, recd001-1-log.0000000001,
# and so on.
# We may also have log.0000000001, log.0000000002,
# and so on, and they will all be dumped together
# by db_printlog.
set count 0
while { [file exists \
$dest/$upgrade_name-$count-log.tar.gz] \
== 1 } {
incr count
}
set newname $upgrade_name-$count-log
# Run db_printlog on all the log files
if {[catch {exec $util_path/db_printlog -h $dir > \
$dir/$newname.prlog} res] != 0} {
puts "Regular printlog failed, try encryption"
eval {exec $util_path/db_printlog} -h $dir \
-P $passwd > $dir/$newname.prlog
}
# Rename each log file so we can identify which
# recd test created it.
foreach logfile $logfiles {
set lognum [string range $logfile \
end-9 end]
file rename $logfile $dir/$newname.$lognum
}
set cwd [pwd]
cd $dir
catch {eval exec tar -cvf $dest/$newname.tar \
[glob $newname*]}
catch {exec gzip -9v $dest/$newname.tar}
cd $cwd
}
}
if { $gen_dump == 1 } {
# Save dump files. We require that the files have
# been created with the extension .dmp.
set dumpfiles [glob -nocomplain $dir/*.dmp]
foreach dumpfile $dumpfiles {
set basename [string range $dumpfile \
[expr [string length $dir] + 1] end-4]
set newbasename $upgrade_name-$basename
# Rename dumpfile.
file rename $dumpfile $dir/$newbasename.dmp
set cwd [pwd]
cd $dir
catch {eval exec tar -cvf $dest/$newbasename.tar \
[glob $newbasename.dmp]}
catch {exec gzip -9v $dest/$newbasename.tar} res
cd $cwd
}
}
}
proc upgrade_dump { database file {stripnulls 0} } {
global errorInfo
global encrypt
global passwd
set encargs ""
if { $encrypt == 1 } {
set encargs " -encryptany $passwd "
}
set db [eval {berkdb open} -rdonly $encargs $database]
set dbc [$db cursor]
set f [open $file w+]
fconfigure $f -encoding binary -translation binary
#
# Get a sorted list of keys
#
set key_list ""
set pair [$dbc get -first]
while { 1 } {
if { [llength $pair] == 0 } {
break
}
set k [lindex [lindex $pair 0] 0]
lappend key_list $k
set pair [$dbc get -next]
}
# Discard duplicated keys; we now have a key for each
# duplicate, not each unique key, and we don't want to get each
# duplicate multiple times when we iterate over key_list.
set uniq_keys ""
foreach key $key_list {
if { [info exists existence_list($key)] == 0 } {
lappend uniq_keys $key
}
set existence_list($key) 1
}
set key_list $uniq_keys
set key_list [lsort -command _comp $key_list]
#
# Get the data for each key
#
set i 0
foreach key $key_list {
set pair [$dbc get -set $key]
if { $stripnulls != 0 } {
# the Tcl interface to db versions before 3.X
# added nulls at the end of all keys and data, so
# we provide functionality to strip that out.
set key [strip_null $key]
}
set data_list {}
catch { while { [llength $pair] != 0 } {
set data [lindex [lindex $pair 0] 1]
if { $stripnulls != 0 } {
set data [strip_null $data]
}
lappend data_list [list $data]
set pair [$dbc get -nextdup]
} }
#lsort -command _comp data_list
set data_list [lsort -command _comp $data_list]
puts -nonewline $f [binary format i [string length $key]]
puts -nonewline $f $key
puts -nonewline $f [binary format i [llength $data_list]]
for { set j 0 } { $j < [llength $data_list] } { incr j } {
puts -nonewline $f [binary format i [string length \
[concat [lindex $data_list $j]]]]
puts -nonewline $f [concat [lindex $data_list $j]]
}
if { [llength $data_list] == 0 } {
puts "WARNING: zero-length data list"
}
incr i
}
close $f
error_check_good upgrade_dump_c_close [$dbc close] 0
error_check_good upgrade_dump_db_close [$db close] 0
}
proc _comp { a b } {
if { 0 } {
# XXX
set a [strip_null [concat $a]]
set b [strip_null [concat $b]]
#return [expr [concat $a] < [concat $b]]
} else {
set an [string first "\0" $a]
set bn [string first "\0" $b]
if { $an != -1 } {
set a [string range $a 0 [expr $an - 1]]
}
if { $bn != -1 } {
set b [string range $b 0 [expr $bn - 1]]
}
}
#puts "$a $b"
return [string compare $a $b]
}
proc strip_null { str } {
set len [string length $str]
set last [expr $len - 1]
set termchar [string range $str $last $last]
if { [string compare $termchar \0] == 0 } {
set ret [string range $str 0 [expr $last - 1]]
} else {
set ret $str
}
return $ret
}
proc get_log_vers { env } {
set stat [$env log_stat]
foreach pair $stat {
set msg [lindex $pair 0]
set val [lindex $pair 1]
if { $msg == "Log file Version" } {
return $val
}
}
puts "FAIL: Log file Version not found in log_stat"
return 0
}
|