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