/
Util.pm
102 lines (83 loc) · 2.07 KB
/
Util.pm
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
package xt::Util;
use strict;
use warnings;
use Test::Builder;
use File::Temp qw(tempdir);
use File::Path qw(mkpath);
use File::Basename qw(dirname);
use Cwd qw(getcwd);
use Config qw(%Config);
use YAML::Tiny;
use Capture::Tiny qw(capture_merged);
use base qw(Exporter);
use constant DMAKE => $^O eq 'MSWin32' && $Config{make} =~ /dmake(?:\.exe)?$/i;
use constant NMAKE => $^O eq 'MSWin32' && $Config{make} =~ /nmake(?:\.exe)?$/i;
use constant MAKE => $Config{make} || 'make';
our @EXPORT = qw/make_meta_data unpack_tree build run_make DMAKE NMAKE/;
sub make_meta_data {
my $fh = shift;
local $ENV{PERL5LIB} = join $Config{path_sep},
map { File::Spec->rel2abs($_) } @INC;
my $cwd = getcwd;
my $tmpdir = tempdir CLEANUP => 1;
chdir $tmpdir or die $!;
unpack_tree($fh);
my $yaml = eval {
build($cwd);
YAML::Tiny->read('META.yml');
};
chdir $cwd or die $!;
die $@ if $@;
return $yaml->[0];
}
sub build {
my $distdir = shift;
die "Makefile.PL not found" unless -f 'Makefile.PL';
my $tb = Test::Builder->new;
$tb->note( run_cmd(qq{$^X Makefile.PL}) );
run_make();
}
sub run_cmd {
my ($cmd) = @_;
my $result = capture_merged {
system $cmd;
};
die "`$cmd` failed ($result)" if $?;
return $result;
}
sub run_make {
run_cmd(join ' ', MAKE, @_);
}
sub _parse_data {
my $fh = shift;
my ($data, $path);
while (<$fh>) {
if (/^\@\@/) {
($path) = $_ =~ /^\@\@ (.*)/;
next;
}
$data->{$path} .= $_;
}
close $fh;
return $data;
}
sub unpack_tree {
my $data = _parse_data(shift);
for my $path (keys %$data) {
my $dir = dirname($path);
unless (-e $dir) {
mkpath($dir) or die "Cannot mkpath '$dir': $!";
}
my $content = $data->{$path};
open my $out, '>', $path or die "Cannot open '$path' for writing: $!";
print $out $content;
close $out;
}
}
sub _regex {
my @target = @_;
my $regex = join '|', @target;
return qr/$regex/;
}
1;
__END__