package
XS::Install::Deps;
use strict;
use warnings;
use Cwd 'abs_path';
use File::Spec;
sub find_header_deps {
my $p = shift;
my $headers = [ grep {$_} map { abs_path($_) } @{$p->{headers} || []} ];
my $inc = [ grep {$_} map { abs_path($_) } @{$p->{inc} || []} ];
my $cache = {};
$headers = undef unless @$headers;
my %ret;
foreach my $file (@{$p->{files}}) {
my $absfile = eval { abs_path($file) } or next;
next unless -f $absfile;
my $deps = _find_header_deps($absfile, $cache, $inc, $headers) or next;
$ret{$file} = [keys %$deps];
}
return \%ret;
}
sub _find_header_deps {
my ($file, $cache, $inc, $headers) = @_;
return $cache->{$file} if exists $cache->{$file};
my $deps = $cache->{$file} = {};
my $content = readfile($file);
my $dir = $file;
$dir =~ s#[^/\\]+$##;
while ($content =~ /^\s*#\s*include\s*("|<)([^">]+)(?:"|>)/mg) {
my ($type, $dep) = ($1, $2);
my $absdep;
if ($type eq '"') { # try to find locally first
$absdep = getfile($dir.$dep);
}
unless ($absdep) { # try to find globally
foreach my $dir (@$inc) {
$absdep = getfile($dir.'/'.$dep);
last if $absdep;
}
}
if ($absdep and $headers) { # if supplied, ignore everything that is outside of specified dirs
my $found;
foreach my $dir (@$headers) {
next unless index($absdep, $dir) == 0;
$found = 1;
last;
}
$absdep = undef unless $found;
}
next unless $absdep;
$deps->{File::Spec->abs2rel($absdep)}++;
my $subdeps = _find_header_deps($absdep, $cache, $inc, $headers);
$deps->{$_}++ for keys %$subdeps;
}
return $deps;
}
sub find_xsi_deps {
my $files = shift;
my %ret;
foreach my $file (@$files) {
my $absfile = abs_path($file) or next;
next unless -f $absfile;
my $deps = _find_xsi_deps($absfile) or next;
$ret{$file} = [keys %$deps];
}
return \%ret;
}
sub _find_xsi_deps {
my $file = shift;
my $content = readfile($file);
my $dir = $file;
$dir =~ s#[^/\\]+$##;
my $deps = {};
while ($content =~ /^\s*INCLUDE\s*:\s*(.+)/mg) {
my $xsi = getfile($dir.$1) or next;
$deps->{File::Spec->abs2rel($xsi)}++;
my $subdeps = _find_xsi_deps($xsi);
$deps->{$_}++ for keys %$subdeps;
}
return $deps;
}
sub getfile {
my $f = abs_path($_[0]);
return undef unless $f and -f $f;
return $f;
}
sub readfile {
my $file = shift;
open my $fh, '<', $file or die "cannot open $file: $!";
local $/ = undef;
my $content = <$fh>;
close $fh;
return $content;
}
1;