package Test::Utils; use strict; use Exporter; use Test::More; use FileHandle; use File::Spec::Functions qw( :ALL ); use vars qw( @EXPORT @ISA ); use Mail::Mbox::MessageParser; @ISA = qw( Exporter ); @EXPORT = qw( Do_Diff Module_Installed %PROGRAMS Broken_Pipe No_such_file_or_directory $single_quote $command_separator $set_env ); use vars qw( %PROGRAMS $single_quote $command_separator $set_env ); if ($^O eq 'MSWin32') { $set_env = 'set'; $single_quote = '"'; $command_separator = '&'; } else { $set_env = ''; $single_quote = "'"; $command_separator = ''; } %PROGRAMS = ( 'gzip' => '/usr/cs/contrib/bin/gzip', 'compress' => '/usr/cs/contrib/bin/gzip', 'bzip' => undef, 'bzip2' => undef, ); # --------------------------------------------------------------------------- sub Do_Diff { my $filename = shift; my $output_filename = shift; local $Test::Builder::Level = 2; my (@data1,@data2); { open IN, $filename; @data1 = ; close IN; } { open IN, $output_filename; @data2 = ; close IN; } is_deeply(\@data1,\@data2,"$filename compared to $output_filename"); } # --------------------------------------------------------------------------- sub Module_Installed { my $module_name = shift; $module_name =~ s#::#/#g; $module_name .= '.pm'; foreach my $inc (@INC) { return 1 if -e catfile($inc,$module_name); } return 0; } # --------------------------------------------------------------------------- sub No_such_file_or_directory { my $filename = 0; $filename++ while -e $filename; local $!; my $foo = new FileHandle; $foo->open($filename); die q{Couldn't determine local text for "No such file or directory"} if $! eq ''; return $!; } # --------------------------------------------------------------------------- # I think this works, but I haven't been able to test it because I can't find # a system which will report a broken pipe. Also, is there a pure Perl way of # doing this? sub Broken_Pipe { mkdir catdir('t','temp'), 0700; my $script_path = catfile('t','temp','broken_pipe.pl'); my $dev_null = devnull(); open F, ">$script_path"; print F<$dev_null"); print F 'x'; close F; exit; } EOF close F; my $result = `$^X $script_path 2>&1 1>$dev_null`; $result = '' unless defined $result; return $result; } # --------------------------------------------------------------------------- 1;