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