view release on metacpan or  search on metacpan

lib/AutoSplit.pm  view on Meta::CPAN

# ./miniperl -e 'use AutoSplit; autosplit_lib_modules(@ARGV)' ...

sub autosplit_lib_modules {
    my(@modules) = @_; # list of Module names
    local $_; # Avoid clobber.
    while (defined($_ = shift @modules)) {
	while (m#([^:]+)::([^:].*)#) { # in case specified as ABC::XYZ
	    $_ = catfile($1, $2);
	}
	s|\\|/|g;		# bug in ksh OS/2
	s#^lib/##s; # incase specified as lib/*.pm
	my($lib) = catfile(curdir(), "lib");
	if ($Is_VMS) { # may need to convert VMS-style filespecs
	    $lib =~ s#^\[\]#.\/#;
	}
	s#^$lib\W+##s; # incase specified as ./lib/*.pm
	if ($Is_VMS && /[:>\]]/) { # may need to convert VMS-style filespecs
	    my ($dir,$name) = (/(.*])(.*)/s);
	    $dir =~ s/.*lib[\.\]]//s;
	    $dir =~ s#[\.\]]#/#g;
	    $_ = $dir . $name;
	}
	autosplit_file(catfile($lib, $_), catfile($lib, "auto"),
		       $Keep, $CheckForAutoloader, $CheckModTime);
    }
    0;
}


# private functions

my $self_mod_time = (stat __FILE__)[9];

sub autosplit_file {
    my($filename, $autodir, $keep, $check_for_autoloader, $check_mod_time)
	= @_;
    my(@outfiles);
    local($_);
    local($/) = "\n";

    # where to write output files
    $autodir ||= catfile(curdir(), "lib", "auto");
    if ($Is_VMS) {
	($autodir = VMS::Filespec::unixpath($autodir)) =~ s|/\z||;
	$filename = VMS::Filespec::unixify($filename); # may have dirs
    }
    unless (-d $autodir){
	mkpath($autodir,0,0755);
	# We should never need to create the auto dir
	# here. installperl (or similar) should have done
	# it. Expecting it to exist is a valuable sanity check against
	# autosplitting into some random directory by mistake.
	print "Warning: AutoSplit had to create top-level " .
	    "$autodir unexpectedly.\n";
    }

    # allow just a package name to be used
    $filename .= ".pm" unless ($filename =~ m/\.pm\z/);

    open(my $in, "<$filename") or die "AutoSplit: Can't open $filename: $!\n";
    my($pm_mod_time) = (stat($filename))[9];
    my($autoloader_seen) = 0;
    my($in_pod) = 0;
    my($def_package,$last_package,$this_package,$fnr);
    while (<$in>) {
	# Skip pod text.
	$fnr++;
	$in_pod = 1 if /^=\w/;
	$in_pod = 0 if /^=cut/;
	next if ($in_pod || /^=cut/);
        next if /^\s*#/;

	# record last package name seen
	$def_package = $1 if (m/^\s*package\s+([\w:]+)\s*;/);
	++$autoloader_seen if m/^\s*(use|require)\s+AutoLoader\b/;
	++$autoloader_seen if m/\bISA\s*=.*\bAutoLoader\b/;
	last if /^__END__/;
    }
    if ($check_for_autoloader && !$autoloader_seen){
	print "AutoSplit skipped $filename: no AutoLoader used\n"
	    if ($Verbose>=2);
	return 0;
    }
    $_ or die "Can't find __END__ in $filename\n";

    $def_package or die "Can't find 'package Name;' in $filename\n";

    my($modpname) = _modpname($def_package); 

    # this _has_ to match so we have a reasonable timestamp file
    die "Package $def_package ($modpname.pm) does not ".
	"match filename $filename"
	    unless ($filename =~ m/\Q$modpname.pm\E$/ or
		    ($^O eq 'dos') or ($^O eq 'MSWin32') or ($^O eq 'NetWare') or
	            $Is_VMS && $filename =~ m/$modpname.pm/i);

    my($al_idx_file) = catfile($autodir, $modpname, $IndexFile);

    if ($check_mod_time){
	my($al_ts_time) = (stat("$al_idx_file"))[9] || 1;
	if ($al_ts_time >= $pm_mod_time and
	    $al_ts_time >= $self_mod_time){
	    print "AutoSplit skipped ($al_idx_file newer than $filename)\n"
		if ($Verbose >= 2);
	    return undef;	# one undef, not a list
	}
    }

    my($modnamedir) = catdir($autodir, $modpname);
    print "AutoSplitting $filename ($modnamedir)\n"
	if $Verbose;

    unless (-d $modnamedir){
	mkpath($modnamedir,0,0777);
    }

    # We must try to deal with some SVR3 systems with a limit of 14
    # characters for file names. Sadly we *cannot* simply truncate all
    # file names to 14 characters on these systems because we *must*
    # create filenames which exactly match the names used by AutoLoader.pm.
    # This is a problem because some systems silently truncate the file
    # names while others treat long file names as an error.

    my $Is83 = $maxflen==11;  # plain, case INSENSITIVE dos filenames

    my(@subnames, $subname, %proto, %package);
    my @cache = ();
    my $caching = 1;
    $last_package = '';
    my $out;
    while (<$in>) {
	$fnr++;
	$in_pod = 1 if /^=\w/;
	$in_pod = 0 if /^=cut/;
	next if ($in_pod || /^=cut/);
	# the following (tempting) old coding gives big troubles if a
	# cut is forgotten at EOF:
	# next if /^=\w/ .. /^=cut/;
	if (/^package\s+([\w:]+)\s*;/) {
	    $this_package = $def_package = $1;
	}

	if (/^sub\s+([\w:]+)(\s*(?:\(.*?\))?(?:$attr_list)?)/) {
	    print $out "# end of $last_package\::$subname\n1;\n"
		if $last_package;
	    $subname = $1;
	    my $proto = $2 || '';
	    if ($subname =~ s/(.*):://){
		$this_package = $1;
	    } else {
		$this_package = $def_package;
	    }
	    my $fq_subname = "$this_package\::$subname";
	    $package{$fq_subname} = $this_package;
	    $proto{$fq_subname} = $proto;
	    push(@subnames, $fq_subname);
	    my($lname, $sname) = ($subname, substr($subname,0,$maxflen-3));
	    $modpname = _modpname($this_package);
            my($modnamedir) = catdir($autodir, $modpname);
	    mkpath($modnamedir,0,0777);