t/common.pm

   1 package # Hide from PAUSE
   2     t::common;
   3
   4 use 5.006_000;
   5
   6 use strict;
   7 use warnings;
   8
   9 our $VERSION = '0.01';
  10
  11 use base 'Exporter';
  12 our @EXPORT_OK = qw(
  13     new_dbm
  14     new_fh
  15 );
  16
  17 use File::Spec ();
  18 use File::Temp qw( tempfile tempdir );
  19 use Fcntl qw( :flock );
  20
  21 my $parent = $ENV{WORK_DIR} || File::Spec->tmpdir;
  22 my $dir = tempdir( CLEANUP => 1, DIR => $parent );
  23 #my $dir = tempdir( DIR => '.' );
  24
  25 sub new_fh {
  26     my ($fh, $filename) = tempfile( 'tmpXXXX', DIR => $dir, UNLINK => 1 );
  27
  28     # This is because tempfile() returns a flock'ed $fh on MacOSX.
  29     flock $fh, LOCK_UN;
  30
  31     return ($fh, $filename);
  32 }
  33
  34 sub new_dbm {
  35     my @args = @_;
  36     my ($fh, $filename) = new_fh();
  37     my @extra_args = (
  38         [ file => $filename ],
  39     );
  40     return sub {
  41         return unless @extra_args;
  42         my @these_args = @{ shift @extra_args };
  43         return sub {
  44             DBM::Deep->new(
  45                 @these_args, @args,
  46             );
  47         };
  48     };
  49 }
  50
  51 1;
  52 __END__