[p5sagit/p5-mst-13.2.git] / lib / AutoSplit.pm

package AutoSplit;

require 5.000;
require Exporter;

use Config;
use Carp;

@ISA = qw(Exporter);
@EXPORT = qw(&autosplit &autosplit_lib_modules);
@EXPORT_OK = qw($Verbose $Keep $Maxlen $CheckForAutoloader $CheckModTime);

=head1 NAME

AutoSplit - split a package for autoloading

=head1 DESCRIPTION

This function will split up your program into files that the AutoLoader
module can handle.  Normally only used to build autoloading Perl library
modules, especially extensions (like POSIX).  You should look at how
they're built out for details.

=cut

# for portability warn about names longer than $maxlen
$Maxlen  = 8;	# 8 for dos, 11 (14-".al") for SYSVR3
$Verbose = 1;	# 0=none, 1=minimal, 2=list .al files
$Keep    = 0;
$CheckForAutoloader = 1;
$CheckModTime = 1;

$IndexFile = "autosplit.ix";	# file also serves as timestamp
$maxflen = 255;
$maxflen = 14 if $Config{'d_flexfnam'} ne 'define';
$vms = ($Config{'osname'} eq 'VMS');


sub autosplit{
    my($file, $autodir,  $k, $ckal, $ckmt) = @_;
    # $file    - the perl source file to be split (after __END__)
    # $autodir - the ".../auto" dir below which to write split subs
    # Handle optional flags:
    $keep = $Keep unless defined $k;
    $ckal = $CheckForAutoloader unless defined $ckal;
    $ckmt = $CheckModTime unless defined $ckmt;
    autosplit_file($file, $autodir, $keep, $ckal, $ckmt);
}


# This function is used during perl building/installation
# ./miniperl -e 'use AutoSplit; autosplit_modules(@ARGV)' ...

sub autosplit_lib_modules{
    my(@modules) = @_; # list of Module names

    foreach(@modules){
	s#::#/#g;	# incase specified as ABC::XYZ
	s#^lib/##; # incase specified as lib/*.pm
	if ($vms && /[:>\]]/) { # may need to convert VMS-style filespecs
	    my ($dir,$name) = (/(.*])(.*)/);
	    $dir =~ s/.*lib[\.\]]//;
	    $dir =~ s#[\.\]]#/#g;
	    $_ = $dir . $name;
	}
	autosplit_file("lib/$_", "lib/auto", $Keep, $CheckForAutoloader, $CheckModTime);
    }
    0;
}


# private functions

sub autosplit_file{
    my($filename, $autodir, $keep, $check_for_autoloader, $check_mod_time) = @_;
    my(@names);

    # where to write output files
    $autodir = "lib/auto" unless $autodir;
    unless (-d $autodir){
	local($", @p)="/";
	foreach(split(/\//,$autodir)){
	    push(@p, $_);
	    next if -d "@p/";
	    mkdir("@p",0755) or die "AutoSplit unable to mkdir @p: $!";
	}
	# 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$/);

    open(IN, "<$filename") || die "AutoSplit: Can't open $filename: $!\n";
    my($pm_mod_time) = (stat($filename))[9];
    my($autoloader_seen) = 0;
    my($in_pod) = 0;
    while (<IN>) {
	# Skip pod text.
	$in_pod = 1 if /^=/;
	$in_pod = 0 if /^=cut/;
	next if ($in_pod || /^=cut/);

	# record last package name seen
	$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/;
	++$autoloader_seen if m/^\s*sub\s+AUTOLOAD\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";

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

    my($modpname) = $package; $modpname =~ s#::#/#g;
    my($al_idx_file) = "$autodir/$modpname/$IndexFile";

    die "Package $package does not match filename $filename"
	    unless ($filename =~ m/$modpname.pm$/ or
	            $vms && $filename =~ m/$modpname.pm/i);

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

    my($from) = ($Verbose>=2) ? "$filename => " : "";
    print "AutoSplitting $package ($from$autodir/$modpname)\n"
	if $Verbose;

    unless (-d "$autodir/$modpname"){
	local($", @p)="/";
	foreach(split(/\//,"$autodir/$modpname")){
	    push(@p, $_);
	    next if -d "@p/";
	    mkdir("@p",0777) or die "AutoSplit unable to mkdir @p: $!";
	}
    }

    # 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.

    # We do not yet deal with multiple packages within one file.
    # Ideally both of these styles should work.
    #
    #   package NAME;
    #   __END__
    #   sub AAA { ... }
    #   package NAME::option1;
    #   sub BBB { ... }
    #   package NAME::option2;
    #   sub BBB { ... }
    #
    #   package NAME;
    #   __END__
    #   sub AAA { ... }
    #   sub NAME::option1::BBB { ... }
    #   sub NAME::option2::BBB { ... }
    #
    # For now both of these produce warnings.

    open(OUT,">/dev/null") || open(OUT,">nla0:"); # avoid 'not opened' warning
    my(@subnames);
    while (<IN>) {
	if (/^package ([\w:]+)\s*;/) {
	    warn "package $1; in AutoSplit section ignored. Not currently supported.";
	}
	if (/^sub ([\w:]+)/) {
	    print OUT "1;\n";
	    my($subname) = $1;
	    if ($subname =~ m/::/){
		warn "subs with package names not currently supported in AutoSplit section";
	    }
	    push(@subnames, $subname);
	    my($lname, $sname) = ($subname, substr($subname,0,$maxflen-3));
	    my($lpath) = "$autodir/$modpname/$lname.al";
	    my($spath) = "$autodir/$modpname/$sname.al";
	    unless(open(OUT, ">$lpath")){
		open(OUT, ">$spath") or die "Can't create $spath: $!\n";
		push(@names, $sname);
		print "  writing $spath (with truncated name)\n"
			if ($Verbose>=1);
	    }else{
		push(@names, $lname);
		print "  writing $lpath\n" if ($Verbose>=2);
	    }
	    print OUT "# NOTE: Derived from $filename.  ",
			"Changes made here will be lost.\n";
	    print OUT "package $package;\n\n";
	}
	print OUT $_;
    }
    print OUT "1;\n";
    close(OUT);
    close(IN);

    if (!$keep){  # don't keep any obsolete *.al files in the directory
	my(%names);
	@names{@names} = @names;
	opendir(OUTDIR,"$autodir/$modpname");
	foreach(sort readdir(OUTDIR)){
	    next unless /\.al$/;
	    my($subname) = m/(.*)\.al$/;
	    next if $names{substr($subname,0,$maxflen-3)};
	    my($file) = "$autodir/$modpname/$_";
	    print "  deleting $file\n" if ($Verbose>=2);
	    my($deleted,$thistime);  # catch all versions on VMS
	    do { $deleted += ($thistime = unlink $file) } while ($thistime);
	    carp "Unable to delete $file: $!" unless $deleted;
	}
	closedir(OUTDIR);
    }

    open(TS,">$al_idx_file") or
	carp "AutoSplit: unable to create timestamp file ($al_idx_file): $!";
    print TS "# Index created by AutoSplit for $filename (file acts as timestamp)\n";
    print TS "package $package;\n";
    print TS map("sub $_ ;\n", @subnames);
    print TS "1;\n";
    close(TS);

    check_unique($package, $Maxlen, 1, @names);

    @names;
}


sub check_unique{
    my($module, $maxlen, $warn, @names) = @_;
    my(%notuniq) = ();
    my(%shorts)  = ();
    my(@toolong) = grep(length > $maxlen, @names);

    foreach(@toolong){
	my($trunc) = substr($_,0,$maxlen);
	$notuniq{$trunc}=1 if $shorts{$trunc};
	$shorts{$trunc} = ($shorts{$trunc}) ? "$shorts{$trunc}, $_" : $_;
    }
    if (%notuniq && $warn){
	print "$module: some names are not unique when truncated to $maxlen characters:\n";
	foreach(keys %notuniq){
	    print " $shorts{$_} truncate to $_\n";
	}
    }
    %notuniq;
}

1;
__END__

# test functions so AutoSplit.pm can be applied to itself:
sub test1{ "test 1\n"; }
sub test2{ "test 2\n"; }
sub test3{ "test 3\n"; }
sub test4{ "test 4\n"; }
Commit	Line	Data
a0d0e21e	1	package AutoSplit;
	2
	3	require 5.000;
	4	require Exporter;
	5
	6	use Config;
	7	use Carp;
	8
	9	@ISA = qw(Exporter);
	10	@EXPORT = qw(&autosplit &autosplit_lib_modules);
3edbfbe5	11	@EXPORT_OK = qw($Verbose $Keep $Maxlen $CheckForAutoloader $CheckModTime);
a0d0e21e	12
f06db76b	13	=head1 NAME
	14
	15	AutoSplit - split a package for autoloading
	16
	17	=head1 DESCRIPTION
	18
	19	This function will split up your program into files that the AutoLoader
	20	module can handle. Normally only used to build autoloading Perl library
	21	modules, especially extensions (like POSIX). You should look at how
	22	they're built out for details.
	23
	24	=cut
	25
a0d0e21e	26	# for portability warn about names longer than $maxlen
	27	$Maxlen = 8; # 8 for dos, 11 (14-".al") for SYSVR3
	28	$Verbose = 1; # 0=none, 1=minimal, 2=list .al files
	29	$Keep = 0;
3edbfbe5	30	$CheckForAutoloader = 1;
3edbfbe5	31	$CheckModTime = 1;
a0d0e21e	32
3edbfbe5	33	$IndexFile = "autosplit.ix"; # file also serves as timestamp
a0d0e21e	34	$maxflen = 255;
	35	$maxflen = 14 if $Config{'d_flexfnam'} ne 'define';
	36	$vms = ($Config{'osname'} eq 'VMS');
	37
3edbfbe5	38
a0d0e21e	39	sub autosplit{
75f92628	40	my($file, $autodir, $k, $ckal, $ckmt) = @_;
	41	# $file - the perl source file to be split (after __END__)
	42	# $autodir - the ".../auto" dir below which to write split subs
	43	# Handle optional flags:
	44	$keep = $Keep unless defined $k;
	45	$ckal = $CheckForAutoloader unless defined $ckal;
	46	$ckmt = $CheckModTime unless defined $ckmt;
	47	autosplit_file($file, $autodir, $keep, $ckal, $ckmt);
a0d0e21e	48	}
	49
	50
a0d0e21e	51	# This function is used during perl building/installation
	52	# ./miniperl -e 'use AutoSplit; autosplit_modules(@ARGV)' ...
	53
	54	sub autosplit_lib_modules{
	55	my(@modules) = @_; # list of Module names
	56
	57	foreach(@modules){
	58	s#::#/#g; # incase specified as ABC::XYZ
	59	s#^lib/##; # incase specified as lib/*.pm
	60	if ($vms && /[:>\]]/) { # may need to convert VMS-style filespecs
	61	my ($dir,$name) = (/(.])(.)/);
	62	$dir =~ s/.*lib[\.\]]//;
	63	$dir =~ s#[\.\]]#/#g;
	64	$_ = $dir . $name;
	65	}
3edbfbe5	66	autosplit_file("lib/$_", "lib/auto", $Keep, $CheckForAutoloader, $CheckModTime);
a0d0e21e	67	}
	68	0;
	69	}
	70
	71
	72	# private functions
	73
	74	sub autosplit_file{
	75	my($filename, $autodir, $keep, $check_for_autoloader, $check_mod_time) = @_;
	76	my(@names);
	77
	78	# where to write output files
	79	$autodir = "lib/auto" unless $autodir;
3edbfbe5	80	unless (-d $autodir){
	81	local($", @p)="/";
	82	foreach(split(/\//,$autodir)){
	83	push(@p, $_);
	84	next if -d "@p/";
	85	mkdir("@p",0755) or die "AutoSplit unable to mkdir @p: $!";
	86	}
	87	# We should never need to create the auto dir here. installperl
	88	# (or similar) should have done it. Expecting it to exist is a valuable
	89	# sanity check against autosplitting into some random directory by mistake.
	90	print "Warning: AutoSplit had to create top-level $autodir unexpectedly.\n";
	91	}
a0d0e21e	92
	93	# allow just a package name to be used
	94	$filename .= ".pm" unless ($filename =~ m/\.pm$/);
	95
	96	open(IN, "<$filename") \|\| die "AutoSplit: Can't open $filename: $!\n";
	97	my($pm_mod_time) = (stat($filename))[9];
	98	my($autoloader_seen) = 0;
f06db76b	99	my($in_pod) = 0;
a0d0e21e	100	while (<IN>) {
f06db76b	101	# Skip pod text.
	102	$in_pod = 1 if /^=/;
	103	$in_pod = 0 if /^=cut/;
	104	next if ($in_pod \|\| /^=cut/);
	105
a0d0e21e	106	# record last package name seen
a0d0e21e	107	$package = $1 if (m/^\spackage\s+([\w:]+)\s;/);
3edbfbe5	108	++$autoloader_seen if m/^\s*(use\|require)\s+AutoLoader\b/;
a0d0e21e	109	++$autoloader_seen if m/\bISA\s=.\bAutoLoader\b/;
3edbfbe5	110	++$autoloader_seen if m/^\s*sub\s+AUTOLOAD\b/;
a0d0e21e	111	last if /^__END__/;
a0d0e21e	112	}
3edbfbe5	113	if ($check_for_autoloader && !$autoloader_seen){
	114	print "AutoSplit skipped $filename: no AutoLoader used\n" if ($Verbose>=2);
	115	return 0
	116	}
a0d0e21e	117	$_ or die "Can't find __END__ in $filename\n";
	118
	119	$package or die "Can't find 'package Name;' in $filename\n";
	120
	121	my($modpname) = $package; $modpname =~ s#::#/#g;
	122	my($al_idx_file) = "$autodir/$modpname/$IndexFile";
	123
	124	die "Package $package does not match filename $filename"
	125	unless ($filename =~ m/$modpname.pm$/ or
	126	$vms && $filename =~ m/$modpname.pm/i);
	127
	128	if ($check_mod_time){
	129	my($al_ts_time) = (stat("$al_idx_file"))[9] \|\| 1;
	130	if ($al_ts_time >= $pm_mod_time){
	131	print "AutoSplit skipped ($al_idx_file newer that $filename)\n"
	132	if ($Verbose >= 2);
	133	return undef; # one undef, not a list
	134	}
	135	}
	136
	137	my($from) = ($Verbose>=2) ? "$filename => " : "";
	138	print "AutoSplitting $package ($from$autodir/$modpname)\n"
	139	if $Verbose;
	140
	141	unless (-d "$autodir/$modpname"){
	142	local($", @p)="/";
	143	foreach(split(/\//,"$autodir/$modpname")){
	144	push(@p, $_);
42793c05	145	next if -d "@p/";
a0d0e21e	146	mkdir("@p",0777) or die "AutoSplit unable to mkdir @p: $!";
	147	}
	148	}
	149
	150	# We must try to deal with some SVR3 systems with a limit of 14
	151	# characters for file names. Sadly we cannot simply truncate all
	152	# file names to 14 characters on these systems because we must
	153	# create filenames which exactly match the names used by AutoLoader.pm.
	154	# This is a problem because some systems silently truncate the file
	155	# names while others treat long file names as an error.
	156
	157	# We do not yet deal with multiple packages within one file.
	158	# Ideally both of these styles should work.
	159	#
	160	# package NAME;
	161	# __END__
	162	# sub AAA { ... }
	163	# package NAME::option1;
	164	# sub BBB { ... }
	165	# package NAME::option2;
	166	# sub BBB { ... }
	167	#
	168	# package NAME;
	169	# __END__
	170	# sub AAA { ... }
	171	# sub NAME::option1::BBB { ... }
	172	# sub NAME::option2::BBB { ... }
	173	#
	174	# For now both of these produce warnings.
	175
	176	open(OUT,">/dev/null") \|\| open(OUT,">nla0:"); # avoid 'not opened' warning
	177	my(@subnames);
	178	while (<IN>) {
	179	if (/^package ([\w:]+)\s*;/) {
	180	warn "package $1; in AutoSplit section ignored. Not currently supported.";
	181	}
	182	if (/^sub ([\w:]+)/) {
	183	print OUT "1;\n";
	184	my($subname) = $1;
	185	if ($subname =~ m/::/){
	186	warn "subs with package names not currently supported in AutoSplit section";
	187	}
	188	push(@subnames, $subname);
	189	my($lname, $sname) = ($subname, substr($subname,0,$maxflen-3));
	190	my($lpath) = "$autodir/$modpname/$lname.al";
	191	my($spath) = "$autodir/$modpname/$sname.al";
	192	unless(open(OUT, ">$lpath")){
	193	open(OUT, ">$spath") or die "Can't create $spath: $!\n";
	194	push(@names, $sname);
	195	print " writing $spath (with truncated name)\n"
	196	if ($Verbose>=1);
	197	}else{
	198	push(@names, $lname);
	199	print " writing $lpath\n" if ($Verbose>=2);
	200	}
	201	print OUT "# NOTE: Derived from $filename. ",
	202	"Changes made here will be lost.\n";
	203	print OUT "package $package;\n\n";
	204	}
	205	print OUT $_;
	206	}
	207	print OUT "1;\n";
	208	close(OUT);
	209	close(IN);
210
211	if (!$keep){ # don't keep any obsolete *.al files in the directory
212	my(%names);
213	@names{@names} = @names;
214	opendir(OUTDIR,"$autodir/$modpname");
215	foreach(sort readdir(OUTDIR)){
216	next unless /\.al$/;
217	my($subname) = m/(.*)\.al$/;
218	next if $names{substr($subname,0,$maxflen-3)};
219	my($file) = "$autodir/$modpname/$_";
220	print " deleting $file\n" if ($Verbose>=2);
f06db76b	221	my($deleted,$thistime); # catch all versions on VMS
	222	do { $deleted += ($thistime = unlink $file) } while ($thistime);
	223	carp "Unable to delete $file: $!" unless $deleted;
a0d0e21e	224	}
	225	closedir(OUTDIR);
	226	}
	227
	228	open(TS,">$al_idx_file") or
	229	carp "AutoSplit: unable to create timestamp file ($al_idx_file): $!";
	230	print TS "# Index created by AutoSplit for $filename (file acts as timestamp)\n";
f06db76b	231	print TS "package $package;\n";
a0d0e21e	232	print TS map("sub $_ ;\n", @subnames);
f06db76b	233	print TS "1;\n";
a0d0e21e	234	close(TS);
	235
	236	check_unique($package, $Maxlen, 1, @names);
	237
	238	@names;
	239	}
	240
	241
	242	sub check_unique{
	243	my($module, $maxlen, $warn, @names) = @_;
	244	my(%notuniq) = ();
	245	my(%shorts) = ();
	246	my(@toolong) = grep(length > $maxlen, @names);
	247
	248	foreach(@toolong){
	249	my($trunc) = substr($_,0,$maxlen);
	250	$notuniq{$trunc}=1 if $shorts{$trunc};
	251	$shorts{$trunc} = ($shorts{$trunc}) ? "$shorts{$trunc}, $_" : $_;
	252	}
	253	if (%notuniq && $warn){
	254	print "$module: some names are not unique when truncated to $maxlen characters:\n";
	255	foreach(keys %notuniq){
	256	print " $shorts{$_} truncate to $_\n";
	257	}
	258	}
	259	%notuniq;
	260	}
	261
	262	1;
	263	__END__
	264
	265	# test functions so AutoSplit.pm can be applied to itself:
	266	sub test1{ "test 1\n"; }
	267	sub test2{ "test 2\n"; }
	268	sub test3{ "test 3\n"; }
	269	sub test4{ "test 4\n"; }
	270
	271