1# DESCRIPTION: Perl ExtUtils: Common routines required by package tests 2# 3# Copyright 2002-2016 by Wilson Snyder. This program is free software; 4# you can redistribute it and/or modify it under the terms of either the GNU 5# Lesser General Public License Version 3 or the Perl Artistic License Version 2.0. 6 7use File::Find; 8use IO::File; 9use Cwd; 10use vars qw($PERL $REPO $REPOFN); 11 12if ($ENV{S4_SVN}) { 13 print "unsetenv S4_SVN\n"; 14 delete $ENV{S4_SVN}; # Don't complicate matters 15} 16 17$PERL = "$^X -Iblib/arch -Iblib/lib"; 18$REPOFN = getcwd()."/test_dir/repo"; 19$REPO = "file://localhost$REPOFN"; 20 21mkdir 'test_dir',0777; 22 23$ENV{LANG} = "C"; 24$ENV{LC_ALL} = "C"; # Otherwise expect's will blow up 25 26if (!$ENV{HARNESS_ACTIVE}) { 27 use lib '.'; 28 use lib '..'; 29 use lib "blib/lib"; 30 use lib "blib/arch"; 31 use lib "lib"; 32} 33 34sub run_system { 35 # Run a system command, check errors 36 my $command = shift; 37 print "\t$command\n"; 38 system "$command"; 39 my $status = $?; 40 ($status == 0) or die "%Error: Command Failed $command, $status, stopped"; 41} 42 43sub wholefile { 44 my $file = shift; 45 my $fh = IO::File->new ($file) or die "%Error: $! $file"; 46 my $wholefile = join('',$fh->getlines()); 47 $fh->close(); 48 return $wholefile; 49} 50 51sub files_identical { 52 my $fn1 = shift; 53 my $fn2 = shift; 54 my $f1 = IO::File->new ($fn1) or die "%Error: $! $fn1,"; 55 my $f2 = IO::File->new ($fn2) or die "%Error: $! $fn2,"; 56 my @l1 = $f1->getlines(); 57 my @l2 = $f2->getlines(); 58 my $nl = $#l1; $nl = $#l2 if ($#l2 > $nl); 59 for (my $l=0; $l<$nl; $l++) { 60 if (($l1[$l]||"") ne ($l2[$l]||"")) { 61 warn ("%Warning: Line ".($l+1)." mismatches; $fn1 != $fn2\n" 62 ."F1: ".($l1[$l]||"*EOF*\n") 63 ."F2: ".($l2[$l]||"*EOF*\n")); 64 return 0; 65 } 66 } 67 return 1; 68} 69 70sub write_text { 71 my $filename = shift; 72 my $text = shift; 73 74 my $fh = IO::File->new($filename,"w"); 75 if (!$fh) { 76 warn "%Warning: $! $filename,"; 77 } 78 print $fh $text; 79 $fh->close(); 80} 81 82sub file_list { 83 my $dir = shift; 84 local %files; 85 find({ wanted => sub { 86 return if /\.svn/; 87 $files{$_} = 1; 88 }, follow => 0, no_chdir => 1 }, $dir); 89 my @out = sort keys %files; 90 return \@out; 91} 92 93sub like_cmd ($$) { 94 my $cmd = shift; 95 my $regexp = shift; 96 my $tb = Test::More->builder; 97 my $out = `$cmd`; 98 (my $tell_cmd = $cmd) =~ s/^${PERL} *//; 99 $tb->like($out, $regexp, $tell_cmd); 100} 101 102sub is_cmd ($$) { 103 my $cmd = shift; 104 my $regexp = shift; 105 my $tb = Test::More->builder; 106 my $out = `$cmd`; 107 (my $tell_cmd = $cmd) =~ s/^${PERL} *//; 108 $tb->is_eq($out, $regexp, $tell_cmd); 109} 110 111sub touch ($$) { 112 my $filename = shift; 113 my $contents = shift; 114 my $fh = IO::File->new(">$filename") or die "%Error: $! writing $filename,"; 115 $fh->print($contents); 116 $fh->close; 117} 118 119our $_Svn_Version; 120sub svn_version { 121 if (!defined $_Svn_Version) { 122 my $fh = IO::File->new("svn --version|") 123 or die "%Error: cannot get $self->{svn_binary} --version\n"; 124 while (defined(my $line=$fh->getline)) { 125 if ($line =~ /svn, version ([0-9]+\.[0-9]+)/) { 126 return ($_Svn_Version = $1); 127 } 128 } 129 die "%Error: cannot get svn --version\n"; 130 } 131 return $_Svn_Version; 132} 133 1341; 135