#!perl -w

my $ID = q{ $Id: ModuleFinder.pm,v 1.7 2002/06/18 21:54:46 rose Exp $ };

=head1 NAME

	ModuleFinder
	
=head1 SYNOPSIS

	my $m = ModuleFinder->new( "IO::Select" );
	
	my $m = ModuleFinder->new( "IO::Select", DEBUG => 1 );
	
	my $m = ModuleFinder->new( <path to your perl script> );
	
	$m->show_modules;
	
	$m->modules;
	# returns a reference to an array with used modules
	# in scalar context, an array otherwise
	
	$m->libs;
	# returns a reference to an array with external libraries
	# in scalar context, an array otherwise
	
	usable under MacOS, Win, OS-2, DOS, Unix Systems
	
=head1 DESCRIPTION

The ModuleFinder module *tries* to locate all modules the input will
need at runtime. It does so be searching all "use" and "require" statements
in the input file/input module recursively.

=cut


package ModuleFinder;
use strict;
use Fcntl;

die "VMS unsupported, sorry\n" if $^O =~ /VMS/;

my( $DIRSEP, $RXDIRSEP ) =
	$^O =~ /Mac/ ? ( ':', ':' ) :
		$^O =~ /Win|OS-2|DOS/ ? ( '\\', '\\\\' ) :
			( '/', '/' );

use Cwd;
my $pwd = cwd;
# by convention we try to have no trailing dir separator on any platform
$pwd =~ s/$RXDIRSEP$//o;
## print "DEBUG: pwd = $pwd\n";

my $recursion_level = 0;

# class wide accesible, set in constructor
my $DEBUG = 0;

=head1 METHODS

=item $obj = ModuleFinder->new( $source_file [, DEBUG => 1 ] );

=cut

sub new {
    my $pkg = shift;
    my $sourcefile = shift or die "No input file.";
    my %args = @_;
    $DEBUG = $args{ DEBUG };

	my $self = bless {
			'FILE' => $sourcefile,    # source file
			'INC' => {},              # required modules with full path
			'MOD' => {},              # required modules, e.g. 'Exporter::Heavy'
			'XSLIBS' => {},           # dynamically loaded XS libraries
			'SOURCEDIR' => '',        # save source dir for input scripts
			'AUTOLOADER' => 0,        # flag usage of AutoLoader
			'USELIB_FLAG' => 0,       # flag usage of lib.pm
			'USELIB' => "",           # full path to lib.pm
			'USELIB_DIRS' => {},      # store location of "use lib" directories
			'WITH_DEBUGGER' => 0,     # flag usage of perl debugger
			'CANNOT_LOCATE' => {},    # store modules we cannot locate to improve performance
		}, $pkg;

	local %INC; # keep environment clean
	local $^W = 0; # ignore warning "Subroutine foo redefined"

	print "This is ModuleFinder Version $ID\n" if $DEBUG;
	my $file = $self->_locate_module( $sourcefile );
	die "ERROR: cannot locate input file for '$sourcefile'\n" unless -r $file;
	
	# fill %INC
	if( $self->is_a_sourcescript ) {
		# change naming so "use $sourcefile" doesn't stop with syntax errors
		$file =~ m/^(.*$RXDIRSEP)[^$RXDIRSEP]+$/o and my $sourcedir = $1
			or die "regexp failed on '$file'";
		$sourcedir =~ s/$RXDIRSEP$//o;
		chdir( $sourcedir ) or die "failed to chdir( '$sourcedir' )\n$!";
		$self->{SOURCEDIR} = $sourcedir;
		$self->{FILE} = $file;
		# perl -d involves requiring perl5db.pl
		$self->_check_debugger;
	}

    $self->{INC}->{$file}++;
	$self->_process_file( $file );

	# File::Spec requires "File/Spec/$module"
	# chances are it is "File/Spec/Mac.pm" on Macs, "File/Spec/Unix.pm" under Unix and so on
	#
	for my $file ( keys %{ $self->{INC} } ) {
		if( $file =~ /File${DIRSEP}Spec.pm$/o ) {
			my $specfile;
			if( $^O =~ /Mac/ ) {
				$specfile = $self->_locate_module( "File::Spec::Mac" );
			}
			elsif( $^O =~ /win/i ) {
				$specfile = $self->_locate_module( "File::Spec::Win32" );
			}
			else {
				$specfile = $self->_locate_module( "File::Spec::Unix" );
			}
			$self->{INC}->{$specfile}++;
			$self->_process_file( $specfile ) if -r $specfile;
			last;
		}
	}

	# special #1
	# Net::FTP::I is not found, but most often used if Net::FTP is present
	#
	for my $file ( keys %{ $self->{INC} } ) {
		if( $file =~ /Net${DIRSEP}FTP.pm$/o ) {
			my $netftp_i_file = $self->_locate_module( "Net::FTP::I" );
			$self->{INC}->{$netftp_i_file}++;
			$self->_process_file( $netftp_i_file ) if -r $netftp_i_file;
			last;
		}
	}
	
	# special #2
	# MLDBM used by Mac::Glue 
	# TODO: complete for other modules using MLDBM and perhaps different DBM modules
	#
	$^O =~ /Mac/ and $self->_mldbm_mac_special;

	# get modules required for AutoLoader
	if( $self->{AUTOLOADER} ) {
		### print "DEBUG: need to check autosplitted modules ...\n";
		my $file;
		foreach ( keys %{$self->{INC}} ) {
			$self->_locate_al_module( $_ )
		}
	}
	
	# get dynamically loaded XSLIBS
	for my $file ( keys %{ $self->{INC} } ) {
###		next if $file eq $self->{USELIB};
		open F, $file or die "ERROR: opening '$file'\n$!";
		## ( my $name = $file ) =~ s/^.*$RXDIRSEP([^$RXDIRSEP]+)/$1/;
		while( <F> ) {
			# FIXME: most modules seem to use "bootstrap" on a line by itself, but ...
			#
			if( /bootstrap\s+([\w:]+)\s*/ ) {
				my $name = $1 or die "regex failed for line '$_'";
				print "DEBUG: $file - $name - $1\n" if $DEBUG;
				my $dlmodule = $self->_locate_dl_module( $name );
				if( $dlmodule and -r $dlmodule and ! $self->{XSLIBS}->{$dlmodule} ) {
					$self->{XSLIBS}->{$dlmodule}++
				}
				# FIXME: can we rely to have only a single boostrap command per file?
				#
				last;
			}
		}
		close F;
	}
	return $self;
}

sub _check_debugger {
	my $self = shift;
	my $source = $self->{FILE};
	local *F;
	open F, "<$source" or die "ERROR: opening '$source'\n$!\n";
	my $line = <F>;
	close F;
	# FIXME: -d can be specified an many different ways too
	#
	if( $line =~ /-d/ ) {
		print "Including 'perl5db.pl'\n";
		my $dbfile = $self->_locate_module( 'perl5db.pl' );
		$self->{INC}->{$dbfile}++;
		$self->_process_file( $dbfile );
		# TODO: perl5db does ->do 'dumpvar.pl'<- which we don't handle yet...
		#
		print "Including 'dumpvar.pl'\n";
		$dbfile = $self->_locate_module( 'dumpvar.pl' );
		$self->{INC}->{$dbfile}++;
		$self->_process_file( $dbfile );
	}
}

sub _mldbm_mac_special {
	my $self = shift;
	my $macglue_flag = 0;
	my $serializer;
	
	for my $file ( keys %{ $self->{INC} } ) {
		if( $file =~ /Mac:Glue.pm$/ ) {
			$macglue_flag = 1;
			last;
		}
	}
	return unless $macglue_flag;

	$serializer = 'MLDBM::Serializer::Storable' if $MacPerl::Architecture eq 'MacPPC';
	$serializer = 'MLDBM::Serializer::FreezeThaw' if $MacPerl::Architecture eq 'MacCFM68K';
	die unless $serializer;
	my $serializer_file = $self->_locate_module( $serializer );
	unless( $self->{INC}->{$serializer_file} ) {
		$self->{INC}->{$serializer_file}++;
		$self->_process_file( $serializer_file ) if -r $serializer_file;
	}
	
	# Mac::Glue always accesses DB_file
	my $db_file = $self->_locate_module( 'DB_File' );
	unless( $self->{INC}->{$db_file} ) {
		$self->{INC}->{$db_file}++;
		$self->_process_file( $db_file ) if -r $db_file;
	}	
}

sub _locate_dl_module {
	my( $self, $module ) = @_;
	use DynaLoader;

	# translate module specification into searchable file path
	# Mac::Files -> Mac:Files:Files (Mac/Files/Files.so under *nix)
	# GD -> GD (GD.so under *nix)
	#
	my @modparts = split /::/, $module;
	my $modfname = $modparts[-1];
	my $modpname = join $DIRSEP, @modparts;

	$module = "auto".$DIRSEP.$modpname.$DIRSEP.$modfname;
	if( $DynaLoader::dl_dlext ) { $module .= ".$DynaLoader::dl_dlext" }

	my @searchdirs;
	if( $^O =~ /^Mac/ ) {
		push @searchdirs,
			( $ENV{MACPERL}."lib:MacPPC:", $ENV{MACPERL}."site_perl:MacPPC:" );
	}
	else {
		@searchdirs = ( @INC, @DynaLoader::dl_library_path );
	}

	my $searchdir;
	for $searchdir ( @searchdirs ) {
		# get rid of duplicate dir separators
		$searchdir =~ s/$RXDIRSEP{2,}/$RXDIRSEP/og;
		# and normalize
		$searchdir =~ s/$RXDIRSEP$//o;
		### print "DEBUG: searching '$searchdir$module'\n";
		-r $searchdir.$DIRSEP.$module and return $searchdir.$DIRSEP.$module;
	}
}

sub _locate_al_module {
	my( $self, $file ) = @_;
	$file =~ s/\.pm$//;
	my $libpath;
	foreach $libpath ( @INC ) {
		$libpath =~ s/$RXDIRSEP$//;
		# /o here after the s/// operator influences magically the next pattern ???
		next unless $file =~ /\Q$libpath\E/;

		my( $subpath ) = ( $file =~ /\Q$libpath\E$RXDIRSEP(.+)/ );
		### print "DEBUG: found subpath - \n'$subpath' within\n'$file' using\n'$libpath'\n";
		my $autopath = $libpath.$DIRSEP."auto".$DIRSEP.$subpath;
		### print "DEBUG: checking for existence of '$autopath'\n";
		if( -d $autopath ) {
			### print "DEBUG: found autosplitted submodules in '$autopath'\n";
			local *DIR;
			opendir DIR, $autopath or die $!;
			my @autofiles = grep( /(al|ix)$/, readdir DIR );
			closedir DIR;
			my $autofile;
			foreach $autofile ( @autofiles ) { $self->{INC}->{$autopath.$DIRSEP.$autofile}++ }
		}
	}
}

# recursively go through a file and its required/used modules
#
sub _process_file {
	my $self = shift;
	my $file = shift;
	my $skip_pod_section = 0;
	
	if( $DEBUG ) { print "checking: ", "  " x $recursion_level, "--> $file <--\n" }

	local *F;
	## open( F, "<$file" ) or die "ERROR: while opening file '$file'\n$!";
	!-r $file and die "FATAL: not readable - '$file'\n$!";
	!-f $file and die "internal error: not a plain file: '$file'\n";
	sysopen( F, $file, O_RDONLY ) or die "ERROR: while opening file '$file'\n$!\n";
	while( <F> ) {
		# don't go beyond the code
        last if /^__END__/;

		# save processing time by not looking into POD sections
        if ( ! $skip_pod_section and /^=/ ) {
            $skip_pod_section = 1; next;
        }
        if (   $skip_pod_section and /^=cut/ ) {
            $skip_pod_section = 0; next;
        }
        next if $skip_pod_section;

		next if /^$/;
		next if /^\s*#/;
		next if /use$/;
		next if /use.$/;
		next if /use..$/;
		next if /require$/;
		next if /require.$/;
		next if /require..$/;

		# don't care if the word use/require is not used at all
		next unless /use|require.*;/;
		# and skip those occurences where it's a variable name
		next if /\$(use|require)/;

		# special treatment of ->use lib './lib/';<-
		#
		## if( ! $self->{USELIB_FLAG} and /use\s+lib\s+/ ) {
		if( /use\s+lib\s+/ ) {
			# fill @INC so required modules can be found
			# from the user supplied directory
			#
			eval $_;
			if( $@ ) { print "WARNING: $_ cannot be evaluated\n"; next }
			# convert './lib/' into platform specific path
			# just for Macs, first
			if( $^O =~ /Mac/ ) {
				my $i = 0;
				while( $i < scalar @INC  ) {
					if( $INC[ $i ] ) {
						$INC[ $i ] =~ s/^\.//;
						$INC[ $i ] =~ s|/|$RXDIRSEP|go;
					}
					$i++;
				}
			}
			my $libmodule = $self->_locate_module( "lib" );
			$self->{INC}->{$libmodule}++;
			$self->{USELIB} = $libmodule;
			unless( $self->{USELIB_FLAG} ) {
				$self->{USELIB_FLAG}++;
				$self->_process_file( $libmodule );
			}
			next;
		}
		
		# skip commented lines, with care
		# ->"use MyModule; # use this ..."<-
		# is ok.
		# -># blah, use 'has_exception'<-
		# is not ok.
		#
		next if( /#.*(use|require)/ and !/(use|require).*#/ );
		# skip use/require VERSION
		next if /\b(use|require)\s+\d+/;
		# skip if modules do "eval( require )"
		# not for special case MLDBM
		unless( $file =~ /MLDBM|perl5db|dumpvar/ ) { next if /eval.*\b(use|require)/ }

		# skip if use/require is part of a string
		# FIXME: this does not span multiline q(), qq() constructs
		#
		next if /('|").*(use|require).*('|")/;
		next if /q\(.*(use|require).*\)/;
		next if /q{.*(use|require).*\}/;
		next if /qq\(.*(use|require).*\)/;
		next if /qq{.*(use|require).*\}/;
		# skip empty module requirements
		next if /(use|require)\s+""/;
		next if /(use|require)\s+''/;

		## skip "use constant" (why??)
		## next if /use\s+constant/;
		## skip "use vars"
		## next if /use\s+vars\s+/;

		# skip if use/require is part of a regular expression
		# FIXME: this is incomplete because of the different
		# syntax possible here
		#
		next if m|/.*use.*/| or m|/.*require.*/|;
		next if /\|.*use.*\|/ or /\|.*require.*\|/;

		# TODO
		# do()

		my( $module, $module_name );
		if( /\buse\b/ ) {
			m/\buse\s+(\S+)\b/ and $module = $1
				or print "ERROR: regexp didn't match for : ${_}   from file: $file, line $.\n";
		}
		elsif( /\brequire\b/ ) {
=for test
			# just try by eval whether we can analyze further on
			eval( $_ );
			if( $@ ) {
				print "Skipping: $_";
				next;
			}
=cut
			m/\brequire\s+'?"?(\S+)'?"?\b/ and $module = $1;
			# take care for ->require( 'adir/amodule.pl' );<- syntax, e.g. XML::Parser
			unless( $module ) {
				m/\brequire\s*\('?"?([^'"]+)'?"?\)/ and $module = $1
					and $module =~ s|/|::|g;
			}
			# finally complain
			unless( $module ) {
				print "ERROR: regexp didn't match for : ${_}   from file: $file, line $.\n";
			}
		}

		if( $module ) {
			$module_name = $module;
			if( $module_name =~ /\$/ ) {
				print "Skipping: $_   from file $file, line $.\n";
				next;
			}
			unless( $self->{CANNOT_LOCATE}->{$module_name} or $self->{MOD}->{$module} ) {
				$module = $self->_locate_module( $module );
				unless( $module ) { 
					print "Skipping: cannot locate - '$module_name'\n";
					print "#\tfrom file: $file\n\#\tfrom line: $_";
					$self->{CANNOT_LOCATE}->{$module_name}++;
					next;
				}
				unless( $self->{INC}->{$module} ) {
					$recursion_level++;
					$self->{INC}->{$module}++;
					$self->_process_file( $module );
					$recursion_level--;
				}
			}
		}

	}
	close F;
}

sub _locate_module {
	my $self = shift;
	my $module = shift;
	$DEBUG and print "locating: '$module'\n";
	$self->{MOD}->{$module}++;
	$module =~ s/::/$RXDIRSEP/g;

	## quick workaround for ->use lib 'lib'<-
	#  where a directory exists in the source script path
	unless( $module eq 'lib' ) {
		if( -r $module ) {
			# FIXME: is the check for a DIRSEP safe here?
			# the full path must always be returned
			#
			if( $module =~ /$RXDIRSEP/o ) { return $module }
			else { return $self->{SOURCEDIR}.$DIRSEP.$module }
			### return $module;
			### return $self->{SOURCEDIR}.$DIRSEP.$module;
		}
		-r $pwd.$DIRSEP.$module and return $pwd.$DIRSEP.$module;
		-r $pwd.$DIRSEP.$module.".pl" and return $pwd.$DIRSEP.$module.".pl";
		-r $pwd.$DIRSEP.$module.".pm" and return $pwd.$DIRSEP.$module.".pm";
	}

	my $libpath;
	foreach $libpath ( @INC ) {
		$libpath =~ s/$RXDIRSEP$//; # no /o !!
		if( -r $libpath.$DIRSEP.$module.".pm" ) {
			# flag usage of AutoLoader
			unless( $self->{AUTOLOADER} ) { # unless it is already set
				$self->{AUTOLOADER} = 1 if $module eq "AutoLoader"
			}
			return $libpath.$DIRSEP.$module.".pm";
		}
		if( -r $libpath.$DIRSEP.$module and -f $libpath.$DIRSEP.$module ) {
			# flag usage of AutoLoader
			unless( $self->{AUTOLOADER} ) { # unless it is already set
				$self->{AUTOLOADER} = 1 if $module eq "AutoLoader"
			}
			if( $libpath =~ /^$RXDIRSEP/ ) {
				return $self->{SOURCEDIR}.$libpath.$DIRSEP.$module;
			}
			return $libpath.$DIRSEP.$module;
		}
	}
	warn "NOT FOUND: '$module' (_locate_module)\nfrom file: $module\nfrom line:\n$_";
	return 0;
}

=item $obj->show_modules;

output list of modules and external libraries

=cut
sub show_modules {
    my $self = shift;
    my $autoloaded = 0;
    my $perl_modules = scalar keys %{$self->{INC}};
    my $dl_modules = scalar keys %{$self->{XSLIBS}};

	if( $perl_modules ) {
		for( sort keys %{$self->{INC}} ) {
			print "$_\n";
	        $autoloaded++ if /${DIRSEP}auto${DIRSEP}/o;
		}
	}

	if( $dl_modules ) {
    	print '-' x 60, "\n";
	    for ( sort keys %{$self->{XSLIBS}} ) { print "$_\n" }
	}

   	print '-' x 60, "\n";
   	print "Summary:\n";
   	if( $perl_modules ) { 
   		print $perl_modules, " modules found",
   			$autoloaded ? " ($autoloaded autloaded modules)\n" : "\n";
   	}
   	if( $dl_modules ) { print $dl_modules, " dynamic libraries found\n" }
   	print "=" x 60, "\n";
    print $dl_modules + $perl_modules, " modules total.\n";

}

=item $obj->is_a_sourcescript

return 1 if the scrutinized module is a user supplied source script
or 0 if it is a standard Perl module from the lib path (@INC without
current working dir)

=cut
sub is_a_sourcescript {
	my $self = shift;
	return 1 if (
		-r $self->{FILE} or
		-r $self->{FILE}.".pm" or
		-r $self->{FILE}.".pl" or
		-r $pwd.$DIRSEP.$self->{FILE} or
		-r $pwd.$DIRSEP.$self->{FILE}.".pm" or
		-r $pwd.$DIRSEP.$self->{FILE}.".pl"
	);
	return 0;
}

=item $obj->modules

return a reference to list of modules as full file paths

=cut
sub modules {
	my $self = shift;
	my @return = keys %{$self->{INC}};
	return wantarray ? @return : \@return;
}

=item $obj->libs

return a reference to list of external libraries as full file paths

=cut
sub libs {
	my $self = shift;
	my @return = keys %{$self->{XSLIBS}};
	return wantarray ? @return : \@return;
}

1;

__END__

=head1 BUGS/LIMITATIONS

quite a few, unavoidibly

=head1 VERSION

$Id: ModuleFinder.pm,v 1.7 2002/06/18 21:54:46 rose Exp $

=head1 AUTHOR

Axel Rose, autumn 2001

Thanks for inspiration, assistance, debugging goes to Keitarou Myozaki, Bart Lateur,
Georg Rehfeld and Frank Seitz.

=cut