view release on metacpan or  search on metacpan

t/util.pm  view on Meta::CPAN

package main ;

use strict ;
use BerkeleyDB ;
use File::Path qw(rmtree);
use vars qw(%DB_errors $FA) ;

use vars qw( @StdErrFile );

@StdErrFile = ( -ErrFile => *STDERR, -ErrPrefix => "\n# " ) ;

$| = 1;

%DB_errors = (
    'DB_INCOMPLETE'	=> "DB_INCOMPLETE: Sync was unable to complete",
    'DB_KEYEMPTY'	=> "DB_KEYEMPTY: Non-existent key/data pair",
    'DB_KEYEXIST'	=> "DB_KEYEXIST: Key/data pair already exists",
    'DB_LOCK_DEADLOCK'  => "DB_LOCK_DEADLOCK: Locker killed to resolve a deadlock",
    'DB_LOCK_NOTGRANTED' => "DB_LOCK_NOTGRANTED: Lock not granted",
    'DB_NOTFOUND'	=> "DB_NOTFOUND: No matching key/data pair found",
    'DB_OLD_VERSION'	=> "DB_OLDVERSION: Database requires a version upgrade",
    'DB_RUNRECOVERY'	=> "DB_RUNRECOVERY: Fatal error, run database recovery",
) ;

# full tied array support started in Perl 5.004_57
# just double check.
$FA = 0 ;
{
    sub try::TIEARRAY { bless [], "try" }
    sub try::FETCHSIZE { $FA = 1 }
    my @a ;
    tie @a, 'try' ;
    my $a = @a ;
}

{
    package LexFile ;

    use vars qw( $basename @files ) ;
    $basename = "db0000" ;

    sub new
    {
        my $self = shift ;
        #my @files = () ;
        foreach (@_)
        {
            $_ = $basename ;
            1 while unlink $basename ;
            push @files, $basename ;
            ++ $basename ;
        }
        bless [ @files ], $self ;
    }

    sub DESTROY
    {
        my $self = shift ;
        chmod 0777, @{ $self } ;
        for (@$self) { 1 while unlink $_ } ;
    }

    END
    {
        foreach (@files) { unlink $_ }
    }
}


{
    package LexDir ;

    use File::Path qw(rmtree);

    use vars qw( $basename %dirs ) ;

    sub new
    {
        my $self = shift ;
        my $dir = shift ;

        rmtree $dir if -e $dir ;

        mkdir $dir, 0777 or return undef ;

        return bless [ $dir ], $self ;
    }

    sub DESTROY
    {
        my $self = shift ;
        my $dir = $self->[0];
        #rmtree $dir;
        $dirs{$dir} ++ ;
    }

    END
    {
        foreach (keys %dirs) {
            rmtree $_ if -d $_ ;
        }
    }

}

{
    package Redirect ;
    use Symbol ;

    sub new
    {
        my $class = shift ;
        my $filename = shift ;
	my $fh = gensym ;
	open ($fh, ">$filename") || die "Cannot open $filename: $!" ;
	my $real_stdout = select($fh) ;
	return bless [$fh, $real_stdout ] ;

    }