view release on metacpan or  search on metacpan

t/util.pm  view on Meta::CPAN

sub docat_del
{
    my $file = shift;
    local $/ = undef;
    open(CAT,$file) || die "Cannot open $file: $!";
    my $result = <CAT> || "" ;
    close(CAT);
    unlink $file ;
    $result = normalise($result);
    return $result;
}

sub docat_del_sort
{
    my $file = shift;
    open(CAT,$file) || die "Cannot open $file: $!";
    my @got = <CAT>;
    @got = sort @got;

    my $result = join('', @got) || "" ;
    close(CAT);
    unlink $file ;
    $result = normalise($result);
    return $result;
}

sub readFile
{
    my $file = shift;
    local $/ = undef;
    open(RD,$file) || die "Cannot open $file:$!";
    my $result = <RD>;
    close(RD);
    return $result;
}

sub writeFile
{
    my $name = shift ;
    open(FH, ">$name") or return 0 ;
    print FH @_ ;
    close FH ;
    return 1 ;
}

sub touch
{
    my $file = shift ;
    open(CAT,">$file") || die "Cannot open $file:$!";
    close(CAT);
}

sub joiner
{
    my $db = shift ;
    my $sep = shift ;
    my ($k, $v) = (0, "") ;
    my @data = () ;

    my $cursor = $db->db_cursor()  or return () ;
    for ( my $status = $cursor->c_get($k, $v, DB_FIRST) ;
          $status == 0 ;
          $status = $cursor->c_get($k, $v, DB_NEXT)) {
	push @data, $v ;
    }

    (scalar(@data), join($sep, @data)) ;
}

sub joinkeys
{
    my $db = shift ;
    my $sep = shift || " " ;
    my ($k, $v) = (0, "") ;
    my @data = () ;

    my $cursor = $db->db_cursor()  or return () ;
    for ( my $status = $cursor->c_get($k, $v, DB_FIRST) ;
          $status == 0 ;
          $status = $cursor->c_get($k, $v, DB_NEXT)) {
	push @data, $k ;
    }

    return join($sep, @data) ;

}

sub dumpdb
{
    my $db = shift ;
    my $sep = shift || " " ;
    my ($k, $v) = (0, "") ;
    my @data = () ;

    my $cursor = $db->db_cursor()  or return () ;
    for ( my $status = $cursor->c_get($k, $v, DB_FIRST) ;
          $status == 0 ;
          $status = $cursor->c_get($k, $v, DB_NEXT)) {
	print "  [$k][$v]\n" ;
    }


}

sub countRecords
{
   my $db = shift ;
   my ($k, $v) = (0,0) ;
   my ($count) = 0 ;
   my ($cursor) = $db->db_cursor() ;
   #for ($status = $cursor->c_get($k, $v, DB_FIRST) ;
#	$status == 0 ;
#	$status = $cursor->c_get($k, $v, DB_NEXT) )
   while ($cursor->c_get($k, $v, DB_NEXT) == 0)
     { ++ $count }

   return $count ;
}

sub addData
{
    my $db = shift ;
    my @data = @_ ;
    die "addData odd data\n" if @data % 2 != 0 ;
    my ($k, $v) ;
    my $ret = 0 ;
    while (@data) {
        $k = shift @data ;
        $v = shift @data ;
        $ret += $db->db_put($k, $v) ;
    }

    return ($ret == 0) ;
}



# These two subs lifted directly from MLDBM.pm
#
sub _compare {
    use vars qw(%compared);
    local %compared;
    return _cmp(@_);
}

sub _cmp {
    my($a, $b) = @_;

    # catch circular loops
    return(1) if $compared{$a.'&*&*&*&*&*'.$b}++;
#    print "$a $b\n";
#    print &Data::Dumper::Dumper($a, $b);

    if(ref($a) and ref($a) eq ref($b)) {
	if(eval { @$a }) {
#	    print "HERE ".@$a." ".@$b."\n";
	    @$a == @$b or return 0;
#	    print @$a, ' ', @$b, "\n";
#	    print "HERE2\n";

	    for(0..@$a-1) {
		&_cmp($a->[$_], $b->[$_]) or return 0;
	    }
	} elsif(eval { %$a }) {
	    keys %$a == keys %$b or return 0;
	    for (keys %$a) {
		&_cmp($a->{$_}, $b->{$_}) or return 0;
	    }
	} elsif(eval { $$a }) {
	    &_cmp($$a, $$b) or return 0;
	} else {
	    die("data $a $b not handled");
	}
	return 1;