The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
#!/usr/bin/perl

use strict;
use warnings;
use Test::More;
use File::Temp;
use File::Path qw(mkpath);
use File::Spec;
use FileHandle;
use File::Slurp::Tiny qw(read_file);
use Data::Dumper;

if ( $^O =~ /MSWin32/ ) {
  plan skip_all => 'cannot run on Windows';
}

# -Mblib makes a lot of noise
my $libs = join " ",
 map { '-I' . File::Spec->catfile( 'blib', $_ ) } qw(lib arch);
my $RUN = "$^X $libs examples/perl-reversion";

if ( system( "$RUN -quiet" ) ) {
  plan skip_all => 'cannot run perl-reversion, skipping its tests';
}
plan tests => 44;

my $dir = File::Temp::tempdir( CLEANUP => 1 );

sub find {
  my $rv = _run( @_ );
  if ( $rv->{output} =~ /version is (\S+)$/ ) {
    return { found => $1 };
  }
  else {
    return {};
  }
}

sub _run {
  my $cmd = "$RUN @_";
  #diag $cmd;
  my $output;
  my $pid = open my $fh, '-|';
  die "Could not open pipe: $!" unless defined $pid;
  if ( $pid ) {
    $output = join '', <$fh>;
  }
  else {
    close *STDERR;
    exec $cmd;
  }

  #diag $output;
  return { output => $output };
}

sub with_file {
  my ( $name, $content, $code ) = @_;
  my $fh = FileHandle->new( "> $dir/$name" )
   or die "Can't open $dir/$name: $!";
  binmode $fh;
  print $fh $content;
  close $fh;
  $code->();
  unlink "$dir/$name" or die "Can't unlink $dir/$name: $!";
}

sub count_newlines {
    my @newlines= ("\x{0d}\x{0a}","\x{0d}","\x{0a}");
    my %result;
    for my $name (@_) {
        my $content= read_file($name, binmode => ':raw' );
        
        $result{ $name }= +{
            map {
                my $key= unpack 'H*', $_;
                my $count =()= $content=~ /$_/g;
                $key=>$count
            } @newlines
        };
    };
    %result
};

sub ok_newlines {
    my( $name, %expected ) = @_;
    my %got= count_newlines( keys %expected );
    
    is_deeply \%got, \%expected,
        "$name - All newlines remain intact"
      or diag Dumper [ \%expected, \%got ];
};


sub runtests {
  my ( $name, $version ) = @_;
  
  # Check that we keep line endings consistent:
  my @files= (grep { -f } glob( "$dir/*" ), glob( "$dir/*/*" ) );
  my %newlines= count_newlines( @files );
  
  is_deeply( find( $dir ), { found => '1.2.3' }, "found in $name" );
  is_deeply( find( $dir, "-current=1.2" ),
    {}, "partial does not match" );
  _run( $dir, '-set', '1.2' );
  ok_newlines( "$name -set", %newlines );
  _run( $dir, '-bump' );
  ok_newlines( "$name -bump", %newlines );
  is_deeply(
    find( $dir ),
    { found => '1.3', },
    "-bump did not extend version"
  );
  my $rv = _run( $dir, '-bump-subversion', '2>&1' );
  ok_newlines( "$name -bump-subversion", %newlines );
  like(
    $rv->{output},
    qr/version 1\.3 does not have 'subversion' component/,
    "-bump- with missing component has useful error",
  );
}

FileHandle->new( "> $dir/Makefile.PL" );
mkpath( "$dir/lib" );

with_file(
  "META.yml", <<'END',
---
bar: 2
version: 1.2.3
meta-spec:
  url: whatever
  version: 1.3
END
  sub { runtests( META => '1.2.3' ) },
);

# weirdly indented but still valid
with_file(
  "META.yml", <<'END',
---
   bar: 2
   version: 1.2.3
   meta-spec:
     url: whatever
     version: 1.3
END
  sub { runtests( META => '1.2.3' ) },
);

with_file(
  "lib/Foo_pod.pm", <<'END',
=head1 VERSION

Version 1.2.3

=cut
END
  sub { runtests( pod => "1.2.3" ) },
);

with_file(
  "Foo.pm", <<'END',
package Foo;
our $VERSION = '1.2.3';
1;
END
  sub { runtests( pm => "1.2.3" ) },
);

with_file(
  "Foo.pm", <<'END',
package Foo;
our $VERSION = version->declare('v1.2.3');
1;
END
  sub {
    is_deeply( find( $dir ), { found => 'v1.2.3' }, "found in pm" );
    _run( $dir, '-set', '1.2' );
    _run( $dir, '-bump' );
    is_deeply( find( $dir ), { found => 'v1.3' }, "bump subversion with v prefix" );
  },
);

with_file(
  README => <<'END',
This README describes version 1.2.3 of Flurble.
END
  sub { runtests( plain => "1.2.3" ) },
);

with_file(
  README => "This README describes\x{0d}\x{0a}version 1.2.3 of\x{0d}\x{0a}Flurble.\x{0a}",
  sub { runtests( newlines => "1.2.3" ) },
);