#!/usr/bin/env perl
exit run(@ARGV) unless caller;
sub run {
pod2usage -verbose => 1, -noperldoc => 1 if not @_;
GetOptionsFromArray(\@_,
'spec=s' => \my $spec_file,
'file=s' => \my @files,
'ignore=s' => \my @ignore,
'include=s' => \my @include,
'exclude=s' => \my @exclude,
'filter=s' => \my @filters,
'out=s' => \my $output_file,
'help' => \my $help,
) or pod2usage (
-verbose => 1,
-noperldoc => 1,
-msg => 'Invalid options',
);
pod2usage -verbose => 1, -noperldoc => 1 if $help;
my %args;
%args = %{ YAML::XS::LoadFile($spec_file) } if defined $spec_file;
push @{ $args{files} }, (@files, @{ $args{file} // [] });
push @{ $args{filters} }, (@filters, @{ $args{filter} // [] });
push @{ $args{ignore} }, @ignore;
push @{ $args{include} }, @include;
push @{ $args{exclude} }, @exclude;
my @subs = OpenTracing::WrapScope::ConfigGenerator::examine_files(%args);
open my $fh_out, '>', $output_file if $output_file;
$fh_out //= \*STDOUT;
say {$fh_out} $_ foreach @subs;
return 0;
}
sub _generate_filters {
my ($filter_specs) = @_;
return if not $filter_specs;
state $GENERATORS = {
exclude_private => sub {
return sub {
my ($sub) = @_;
return $sub->name !~ /(?:\A|::)_\w+\z/;
};
},
complexity => sub {
my ($threshold) = @_;
croak 'No arguments for complexity filter' if not $threshold;
return sub {
my ($sub) = @_;
return calculate_mccabe_of_sub($sub) >= $threshold;
};
},
};
my @filters;
foreach (@$filter_specs) {
my ($filter, $arg) = split /=/;
my $generator = $GENERATORS->{$filter} or croak "No such filter: $_";
push @filters, $generator->($arg);
}
return \@filters;
}
sub examine_files {
my %args = @_;
my $files_base = $args{files} // [];
my $files_ignore = $args{ignore} // [];
my $subs_include = $args{include} // [];
my $subs_exclude = $args{exclude} // [];
my $filters = _generate_filters($args{filters});
my @files = grep { -f } map { glob } @$files_base;
my %file_ignored = map { $_ => undef } map { glob } @$files_ignore;
my %sub_excluded = map { $_ => undef } @$subs_exclude;
my @subs = @$subs_include;
foreach my $file (@files) {
next if exists $file_ignored{$file};
foreach my $sub (list_subs($file, $filters)) {
next if exists $sub_excluded{$sub};
push @subs, $sub;
}
}
return uniq @subs;
}
sub list_subs {
my ($filename, $filters) = @_;
my $doc = PPI::Document->new($filename);
my $subs = $doc->find('PPI::Statement::Sub');
return if not $subs;
my @subs;
foreach my $sub (@$subs) {
next if notall { $_->($sub) } @$filters;
if ($sub->name =~ /'|::/) {
push @subs, $sub->name;
}
else {
my $pkg = _detect_package($sub);
$pkg = $pkg ? $pkg->namespace : 'main';
push @subs, $pkg . '::' . $sub->name;
}
}
return @subs;
}
sub _detect_package {
my ($elem) = @_;
return unless $elem;
return $elem if $elem->isa('PPI::Statement::Package');
my $prev = $elem;
while ($prev = $prev->sprevious_sibling) {
return $prev if $prev->isa('PPI::Statement::Package');
}
return _detect_package($elem->parent);
}
1;