ext/Compress/Zlib/t/03examples.t

   1
   2 use strict ;
   3 use warnings ;
   4
   5 use Compress::Zlib;
   6
   7 my $count = 0 ;
   8 sub ok
   9 {
  10     my $ok = shift ;
  11
  12     #++ $total ;
  13     #++ $totalBad unless $ok ;
  14     ++ $count;
  15
  16     print "ok $count\n" if $ok ;
  17     print "not ok $count\n" unless $ok ;
  18     #printf "# Failed test at line %d\n", (caller)[2] unless $ok ;
  19
  20     $ok;
  21 }
  22
  23 sub writeFile
  24 {
  25     my($filename, @strings) = @_ ;
  26     open (F, ">$filename")
  27         or die "Cannot open $filename: $!\n" ;
  28     binmode(F);
  29     foreach (@strings)
  30       { print F }
  31     close F ;
  32 }
  33
  34 sub readFile
  35 {
  36     my ($filename) = @_ ;
  37     my ($string) = '' ;
  38
  39     open (F, "<$filename")
  40         or die "Cannot open $filename: $!\n" ;
  41     binmode(F);
  42     while (<F>)
  43       { $string .= $_ }
  44     close F ;
  45     $string ;
  46 }
  47
  48 sub diag
  49 {
  50     my $msg = shift ;
  51     $msg =~ s/^/# /mg;
  52     #$msg =~ s/\n+$//;
  53     $msg .= "\n" unless $msg =~ /\n\Z/;
  54     print $msg;
  55 }
  56
  57 sub check
  58 {
  59     my $command = shift ;
  60     my $expected = shift ;
  61
  62     my $stderr = 'err.out';
  63     unlink $stderr;
  64
  65     my $cmd = "$command 2>$stderr";
  66     my $stdout = `$cmd` ;
  67
  68     my $aok = 1 ;
  69
  70     $aok &= ok $? == 0
  71         or diag "  exit status is $?" ;
  72
  73     $aok &= ok readFile($stderr) eq ''
  74         or diag "Stderr is: " .  readFile($stderr);
  75
  76     if (defined $expected ) {
  77         $aok &= ok $stdout eq $expected
  78             or diag "got content:\n". $stdout;
  79     }
  80
  81     if (! $aok) {
  82         diag "Command line: $cmd";
  83         my ($file, $line) = (caller)[1,2];
  84         diag "Test called from $file, line $line";
  85     }
  86
  87     unlink $stderr;
  88 }
  89
  90
  91
  92 my $Inc = join " ", map qq["-I$_"] => @INC;
  93 $Inc = '"-MExtUtils::testlib"'
  94     if ! $ENV{PERL_CORE} && eval "require ExtUtils::testlib;" ;
  95
  96 my $Perl = '' ;
  97 $Perl = ($ENV{'FULLPERL'} or $^X or 'perl') ;
  98 $Perl = qq["$Perl"] if $^O eq 'MSWin32' ;
  99
 100 $Perl = "$Perl -w $Inc" ;
 101 my $examples = $ENV{PERL_CORE} ? "../ext/Compress/Zlib/examples"
 102                                : "./examples";
 103
 104 my $hello1 = <<EOM ;
 105 hello
 106 this is
 107 a test
 108 message
 109 x ttttt
 110 xuuuuuu
 111 the end
 112 EOM
 113
 114 my @hello1 = grep(s/$/\n/, split(/\n/, $hello1)) ;
 115
 116 my $hello2 = <<EOM;
 117
 118 Howdy
 119 this is the
 120 second
 121 file
 122 x ppppp
 123 xuuuuuu
 124 really the end
 125 EOM
 126
 127 my @hello2 = grep(s/$/\n/, split(/\n/, $hello2)) ;
 128
 129 my $file1 = "hello1.gz" ;
 130 my $file2 = "hello2.gz" ;
 131 my $stderr = "err.out" ;
 132 unlink $stderr ;
 133
 134 my $gz = gzopen($file1, "wb");
 135 $gz->gzwrite($hello1);
 136 $gz->gzclose();
 137
 138 $gz = gzopen($file2, "wb");
 139 $gz->gzwrite($hello2);
 140 $gz->gzclose();
 141
 142 print "1..16\n" ;
 143
 144
 145
 146 # gzcat
 147 # #####
 148
 149 check "$Perl ${examples}/gzcat $file1 $file2", $hello1 . $hello2 ;
 150
 151 # gzgrep
 152 # ######
 153
 154 check "$Perl ${examples}/gzgrep the $file1 $file2",
 155         join('', grep(/the/, @hello1, @hello2));
 156
 157
 158 unlink $file1, $file2 ;
 159
 160
 161 # filtdef/filtinf
 162 # ##############
 163
 164
 165 writeFile($file1, $hello1) ;
 166 writeFile($file2, $hello2) ;
 167
 168 # there's no way to set binmode on backticks in Win32 so we won't use $a later
 169 check "$Perl ${examples}/filtdef $file1 $file2"; ;
 170
 171 check "$Perl ${examples}/filtdef $file1 $file2 | $Perl ${examples}/filtinf 2>$stderr", $hello1 . $hello2;
 172
 173 # gzstream
 174 # ########
 175
 176 {
 177     writeFile($file1, $hello1) ;
 178     check "$Perl ${examples}/gzstream <$file1 >$file2" ;
 179
 180     check "$Perl ${examples}/gzcat $file2", $hello1;
 181
 182 }
 183
 184
 185 END
 186 {
 187     for ($file1, $file2, $stderr) { 1 while unlink $_ } ;
 188 }