#!/usr/bin/perl

use v5.10;

use open qw(:std :utf8);
use strict;
use warnings;

use Pod::Usage;
use Getopt::Std qw(getopts);

=encoding utf8

=head1 NAME

extract_modules - determine which Perl modules a given file uses

=cut

our $VERSION = '1.104';

=head1 SYNOPSIS

Given Perl files, extract and report the Perl modules included
with C<use> or C<require>.

	# print a verbose text listing
	$ extract_modules filename [...]
	Modules required by examples/extract_modules:
	 - Getopt::Std (first released with Perl 5)
	 - Module::CoreList (first released with Perl 5.008009)
	 - Pod::Usage (first released with Perl 5.006)
	 - strict (first released with Perl 5)
	 - warnings (first released with Perl 5.006)
	5 module(s) in core, 0 external module(s)

	# print a succint list, one module per line
	$ extract_modules -l filename [...]
	Getopt::Std
	Module::CoreList
	Pod::Usage
	open
	strict
	warnings

	# print a succinct list, modules separated by null bytes
	# you might like this with xargs -0
	$ extract_modules -0 filename [...]
	Getopt::StdModule::CoreListPod::Usageopenstrictwarnings

	# print the modules list as JSON
	$ extract_modules -j filename [...]
	[
		"Getopt::Std",
		"Module::CoreList",
		"Pod::Usage",
		"open",
		"strict",
		"warnings"
	]

	# print the modules list as a basic cpanfile
	# https://metacpan.org/pod/cpanfile
	$ extract_modules -c filename [...]
	requires 'Getopt::Std', '1.23';
	requires 'Module::CoreList';
	requires 'Pod::Usage';
	requires 'open';
	requires 'strict';
	requires 'warnings';

=head1 DESCRIPTION

This script does not execute the code in the files it examines. It
uses the C<Module::Extract::Use> or C<Module::ExtractUse> modules
which statically analyze the source without compiling or running it.
These modules cannot discover modules loaded dynamically through a
string eval.

=head2 Command-line options

=over 4

=item * -c  cpanfile output

=item * -e  exclude core modules

=item * -j  JSON output

=item * -l  succint list, one module per line

=item * -0  succint list, modules null separated (for xargs -0)

=cut

run(@ARGV) unless caller;

sub run {
	my @args = @_;
	getopts('ecjl0', \my %opts);

	# if no parameters are passed, give usage information
	unless( @args ) {
		pod2usage( msg => 'Please supply at least one filename to analyze' );
		exit;
		}

	use Data::Dumper;
	my( $object, $method, $sub );
	my @classes = qw( Module::Extract::Use Module::ExtractUse );
	my %methods = (
		'Module::Extract::Use' => [ 'get_modules_with_details', sub {
			[ $_[0]->module, $_[0]->version ];
			} ],
		'Module::ExtractUse' => [ 'extract_use', sub {
			say Dumper( \@_ );
			[ $_[0], undef ];
			} ],
		);

	foreach my $module ( @classes ) {
		eval "require $module";
		next if $@;
		( $object, $method, $sub ) = ( $module->new, @{ $methods{$module} } );
		}

	die "No usable file scanner module found; exiting...\n" .
		"Install one of these modules to make this program work:\n" .
		join( "\n\t", sort keys %methods ) .
		"\n"
		unless defined $object;


	my @Grand_modules;
	foreach my $file ( @args ) {
		unless ( -r $file ) {
			printf STDERR "Could not read $file\n";
			next;
			}

		my @modules = $object->$method( $file );
		my $ref = ref $modules[0] ? $modules[0] : \@modules;
		push @Grand_modules, map { $sub->( $_ ) } @$ref;

		# remove core modules
		@Grand_modules =
			grep { ! defined Module::CoreList->first_release( $_->[0] ) }
			@Grand_modules
			if $opts{e};

		next if $opts{j} || $opts{l} || $opts{0} || $opts{c}; # do these after

		# Handle this here because we want the filename
		long_list( $file, @Grand_modules )
		}

	# Handle these options after going through all the files
	   if( $opts{l} or $opts{0} ) { short_list( \%opts, @Grand_modules ) }
	elsif( $opts{j} )             { json_list(  \%opts, @Grand_modules ) }
	elsif( $opts{c} )             { cpan_file(  \%opts, @Grand_modules ) }
	}

sub short_list {
	state $Seen = {};
	my $opts = shift;

	my $glue = $opts->{0} ? "\000" : "\n";
	print join( $glue,
		grep( { ! $Seen->{$_}++ } sort map { $_->[0] } @_ ),
		''
		);
	}

sub json_list {
	state $Seen = {};
	my $opts = shift;

	my $glue = $opts->{0} ? "\000" : "\n";
	print
		"[\n\t",
		join( ",\n\t",
			map { qq("$_") }
			grep { ! $Seen->{$_}++ }
			sort
			map { $_->[0] }
			@_
			),
		"\n]\n";
	}

sub cpan_file {
	state $Seen = {};
	my $opts = shift;

	foreach my $module ( @_ ) {
		printf "requires '%s'", $module->[0];
		printf ", '%s'", $module->[1] if defined $module->[1];
		print ";\n";
		}
	}

BEGIN {
my $corelist = eval { require Module::CoreList };

sub long_list {
	my( $file, @modules ) = @_;

	printf "Modules required by %s:\n", $file;

	my( $core, $extern ) = ( 0, 0 );

	foreach my $tuple ( @modules ) {
		my( $module, $version ) = @$tuple;
		printf " - $module%s\n",
			$corelist
				?
				do {
					my $v = Module::CoreList->first_release( $module );
					$core++ if $v;
					$v ? " (first released with Perl $v)" : '';
					}
				:
				do { $extern++; '' }
		}

	printf "%d module(s) in core, %d external module(s)\n\n", $core, $extern;
	}

}

=back

=head1 AUTHORS

Jonathan Yu C<< <frequency@cpan.org> >>

brian d foy C<< <bdfoy@cpan.org> >>

=head1 COPYRIGHT & LICENSE

Copyright © 2009-2024, brian d foy <briandfoy@pobox.com>. All rights reserved.

You can use this script under the same terms as Perl itself.

=head1 SEE ALSO

L<Module::Extract::Use>,
L<Module::ExtractUse>,
L<Module::ScanDeps>,

=cut