1package util ;
2
3use strict;
4
5use vars qw( $wantOK) ;
6$wantOK = 1 ;
7
8sub _ok
9{
10    my $no = shift ;
11    my $result = shift ;
12
13    print "not " unless $result ;
14    print "ok $no\n" ;
15    return $result;
16}
17
18sub import
19{
20    my $class = shift ;
21    my $no_want_ok = shift ;
22
23    $wantOK = 0 if $no_want_ok ;
24    if (! $no_want_ok)
25    {
26        *main::ok = \&_ok ;
27    }
28}
29
30package main ;
31
32use strict ;
33use BerkeleyDB ;
34use File::Path qw(rmtree);
35use vars qw(%DB_errors $FA) ;
36
37use vars qw( @StdErrFile );
38
39@StdErrFile = ( -ErrFile => *STDERR, -ErrPrefix => "\n# " ) ;
40
41$| = 1;
42
43%DB_errors = (
44    'DB_INCOMPLETE'	=> "DB_INCOMPLETE: Sync was unable to complete",
45    'DB_KEYEMPTY'	=> "DB_KEYEMPTY: Non-existent key/data pair",
46    'DB_KEYEXIST'	=> "DB_KEYEXIST: Key/data pair already exists",
47    'DB_LOCK_DEADLOCK'  => "DB_LOCK_DEADLOCK: Locker killed to resolve a deadlock",
48    'DB_LOCK_NOTGRANTED' => "DB_LOCK_NOTGRANTED: Lock not granted",
49    'DB_NOTFOUND'	=> "DB_NOTFOUND: No matching key/data pair found",
50    'DB_OLD_VERSION'	=> "DB_OLDVERSION: Database requires a version upgrade",
51    'DB_RUNRECOVERY'	=> "DB_RUNRECOVERY: Fatal error, run database recovery",
52) ;
53
54# full tied array support started in Perl 5.004_57
55# just double check.
56$FA = 0 ;
57{
58    sub try::TIEARRAY { bless [], "try" }
59    sub try::FETCHSIZE { $FA = 1 }
60    my @a ;
61    tie @a, 'try' ;
62    my $a = @a ;
63}
64
65{
66    package LexFile ;
67
68    use vars qw( $basename @files ) ;
69    $basename = "db0000" ;
70
71    sub new
72    {
73        my $self = shift ;
74        #my @files = () ;
75        foreach (@_)
76        {
77            $_ = $basename ;
78            1 while unlink $basename ;
79            push @files, $basename ;
80            ++ $basename ;
81        }
82        bless [ @files ], $self ;
83    }
84
85    sub DESTROY
86    {
87        my $self = shift ;
88        chmod 0777, @{ $self } ;
89        for (@$self) { 1 while unlink $_ } ;
90    }
91
92    END
93    {
94        foreach (@files) { unlink $_ }
95    }
96}
97
98
99{
100    package LexDir ;
101
102    use File::Path qw(rmtree);
103
104    use vars qw( $basename %dirs ) ;
105
106    sub new
107    {
108        my $self = shift ;
109        my $dir = shift ;
110
111        rmtree $dir if -e $dir ;
112
113        mkdir $dir, 0777 or return undef ;
114
115        return bless [ $dir ], $self ;
116    }
117
118    sub DESTROY
119    {
120        my $self = shift ;
121        my $dir = $self->[0];
122        #rmtree $dir;
123        $dirs{$dir} ++ ;
124    }
125
126    END
127    {
128        foreach (keys %dirs) {
129            rmtree $_ if -d $_ ;
130        }
131    }
132
133}
134
135{
136    package Redirect ;
137    use Symbol ;
138
139    sub new
140    {
141        my $class = shift ;
142        my $filename = shift ;
143	my $fh = gensym ;
144	open ($fh, ">$filename") || die "Cannot open $filename: $!" ;
145	my $real_stdout = select($fh) ;
146	return bless [$fh, $real_stdout ] ;
147
148    }
149    sub DESTROY
150    {
151        my $self = shift ;
152	close $self->[0] ;
153	select($self->[1]) ;
154    }
155}
156
157sub normalise
158{
159    my $data = shift ;
160    $data =~ s#\r\n#\n#g
161        if $^O eq 'cygwin' ;
162
163    return $data ;
164}
165
166
167sub docat
168{
169    my $file = shift;
170    local $/ = undef;
171    open(CAT,$file) || die "Cannot open $file:$!";
172    my $result = <CAT>;
173    close(CAT);
174    $result = normalise($result);
175    return $result;
176}
177
178sub docat_del
179{
180    my $file = shift;
181    local $/ = undef;
182    open(CAT,$file) || die "Cannot open $file: $!";
183    my $result = <CAT> || "" ;
184    close(CAT);
185    unlink $file ;
186    $result = normalise($result);
187    return $result;
188}
189
190sub docat_del_sort
191{
192    my $file = shift;
193    open(CAT,$file) || die "Cannot open $file: $!";
194    my @got = <CAT>;
195    @got = sort @got;
196
197    my $result = join('', @got) || "" ;
198    close(CAT);
199    unlink $file ;
200    $result = normalise($result);
201    return $result;
202}
203
204sub writeFile
205{
206    my $name = shift ;
207    open(FH, ">$name") or return 0 ;
208    print FH @_ ;
209    close FH ;
210    return 1 ;
211}
212
213sub touch
214{
215    my $file = shift ;
216    open(CAT,">$file") || die "Cannot open $file:$!";
217    close(CAT);
218}
219
220sub joiner
221{
222    my $db = shift ;
223    my $sep = shift ;
224    my ($k, $v) = (0, "") ;
225    my @data = () ;
226
227    my $cursor = $db->db_cursor()  or return () ;
228    for ( my $status = $cursor->c_get($k, $v, DB_FIRST) ;
229          $status == 0 ;
230          $status = $cursor->c_get($k, $v, DB_NEXT)) {
231	push @data, $v ;
232    }
233
234    (scalar(@data), join($sep, @data)) ;
235}
236
237sub joinkeys
238{
239    my $db = shift ;
240    my $sep = shift || " " ;
241    my ($k, $v) = (0, "") ;
242    my @data = () ;
243
244    my $cursor = $db->db_cursor()  or return () ;
245    for ( my $status = $cursor->c_get($k, $v, DB_FIRST) ;
246          $status == 0 ;
247          $status = $cursor->c_get($k, $v, DB_NEXT)) {
248	push @data, $k ;
249    }
250
251    return join($sep, @data) ;
252
253}
254
255sub dumpdb
256{
257    my $db = shift ;
258    my $sep = shift || " " ;
259    my ($k, $v) = (0, "") ;
260    my @data = () ;
261
262    my $cursor = $db->db_cursor()  or return () ;
263    for ( my $status = $cursor->c_get($k, $v, DB_FIRST) ;
264          $status == 0 ;
265          $status = $cursor->c_get($k, $v, DB_NEXT)) {
266	print "  [$k][$v]\n" ;
267    }
268
269
270}
271
272sub countRecords
273{
274   my $db = shift ;
275   my ($k, $v) = (0,0) ;
276   my ($count) = 0 ;
277   my ($cursor) = $db->db_cursor() ;
278   #for ($status = $cursor->c_get($k, $v, DB_FIRST) ;
279#	$status == 0 ;
280#	$status = $cursor->c_get($k, $v, DB_NEXT) )
281   while ($cursor->c_get($k, $v, DB_NEXT) == 0)
282     { ++ $count }
283
284   return $count ;
285}
286
287sub addData
288{
289    my $db = shift ;
290    my @data = @_ ;
291    die "addData odd data\n" if @data % 2 != 0 ;
292    my ($k, $v) ;
293    my $ret = 0 ;
294    while (@data) {
295        $k = shift @data ;
296        $v = shift @data ;
297        $ret += $db->db_put($k, $v) ;
298    }
299
300    return ($ret == 0) ;
301}
302
303
304
305# These two subs lifted directly from MLDBM.pm
306#
307sub _compare {
308    use vars qw(%compared);
309    local %compared;
310    return _cmp(@_);
311}
312
313sub _cmp {
314    my($a, $b) = @_;
315
316    # catch circular loops
317    return(1) if $compared{$a.'&*&*&*&*&*'.$b}++;
318#    print "$a $b\n";
319#    print &Data::Dumper::Dumper($a, $b);
320
321    if(ref($a) and ref($a) eq ref($b)) {
322	if(eval { @$a }) {
323#	    print "HERE ".@$a." ".@$b."\n";
324	    @$a == @$b or return 0;
325#	    print @$a, ' ', @$b, "\n";
326#	    print "HERE2\n";
327
328	    for(0..@$a-1) {
329		&_cmp($a->[$_], $b->[$_]) or return 0;
330	    }
331	} elsif(eval { %$a }) {
332	    keys %$a == keys %$b or return 0;
333	    for (keys %$a) {
334		&_cmp($a->{$_}, $b->{$_}) or return 0;
335	    }
336	} elsif(eval { $$a }) {
337	    &_cmp($$a, $$b) or return 0;
338	} else {
339	    die("data $a $b not handled");
340	}
341	return 1;
342    } elsif(! ref($a) and ! ref($b)) {
343	return ($a eq $b);
344    } else {
345	return 0;
346    }
347
348}
349
350sub fillout
351{
352    my $var = shift ;
353    my $length = shift ;
354    my $pad = shift || " " ;
355    my $template = $pad x $length ;
356    substr($template, 0, length($var)) = $var ;
357    return $template ;
358}
359
360sub title
361{
362    #diag "" ;
363    ok(1, $_[0]) ;
364    #diag "" ;
365}
366
367
3681;
369