[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|\\|/|g;		# bug in ksh OS/2
	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;
    if ($Config{'osname'} eq 'VMS') {
	($autodir = VMS::Filespec::unixpath($autodir)) =~ s#/$##;
    }
    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/;
	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, %proto);
    while (<IN>) {
	if (/^package ([\w:]+)\s*;/) {
	    warn "package $1; in AutoSplit section ignored. Not currently supported.";
	}
	if (/^sub\s+([\w:]+)(\s*\(.*?\))?/) {
	    print OUT "1;\n";
	    my $subname = $1;
	    $proto{$1} = $2 or '';
	    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 $_$proto{$_} ;\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
4633a7c4	59	s\|\\\|/\|g; # bug in ksh OS/2
a0d0e21e	60	s#^lib/##; # incase specified as lib/*.pm
	61	if ($vms && /[:>\]]/) { # may need to convert VMS-style filespecs
	62	my ($dir,$name) = (/(.])(.)/);
	63	$dir =~ s/.*lib[\.\]]//;
	64	$dir =~ s#[\.\]]#/#g;
	65	$_ = $dir . $name;
	66	}
3edbfbe5	67	autosplit_file("lib/$_", "lib/auto", $Keep, $CheckForAutoloader, $CheckModTime);
a0d0e21e	68	}
	69	0;
	70	}
	71
	72
	73	# private functions
	74
	75	sub autosplit_file{
	76	my($filename, $autodir, $keep, $check_for_autoloader, $check_mod_time) = @_;
	77	my(@names);
	78
	79	# where to write output files
	80	$autodir = "lib/auto" unless $autodir;
4633a7c4	81	if ($Config{'osname'} eq 'VMS') {
	82	($autodir = VMS::Filespec::unixpath($autodir)) =~ s#/$##;
	83	}
3edbfbe5	84	unless (-d $autodir){
	85	local($", @p)="/";
	86	foreach(split(/\//,$autodir)){
	87	push(@p, $_);
	88	next if -d "@p/";
	89	mkdir("@p",0755) or die "AutoSplit unable to mkdir @p: $!";
	90	}
	91	# We should never need to create the auto dir here. installperl
	92	# (or similar) should have done it. Expecting it to exist is a valuable
	93	# sanity check against autosplitting into some random directory by mistake.
	94	print "Warning: AutoSplit had to create top-level $autodir unexpectedly.\n";
	95	}
a0d0e21e	96
	97	# allow just a package name to be used
	98	$filename .= ".pm" unless ($filename =~ m/\.pm$/);
	99
	100	open(IN, "<$filename") \|\| die "AutoSplit: Can't open $filename: $!\n";
	101	my($pm_mod_time) = (stat($filename))[9];
	102	my($autoloader_seen) = 0;
f06db76b	103	my($in_pod) = 0;
a0d0e21e	104	while (<IN>) {
f06db76b	105	# Skip pod text.
	106	$in_pod = 1 if /^=/;
	107	$in_pod = 0 if /^=cut/;
	108	next if ($in_pod \|\| /^=cut/);
	109
a0d0e21e	110	# record last package name seen
a0d0e21e	111	$package = $1 if (m/^\spackage\s+([\w:]+)\s;/);
3edbfbe5	112	++$autoloader_seen if m/^\s*(use\|require)\s+AutoLoader\b/;
a0d0e21e	113	++$autoloader_seen if m/\bISA\s=.\bAutoLoader\b/;
	114	last if /^__END__/;
	115	}
3edbfbe5	116	if ($check_for_autoloader && !$autoloader_seen){
	117	print "AutoSplit skipped $filename: no AutoLoader used\n" if ($Verbose>=2);
	118	return 0
	119	}
a0d0e21e	120	$_ or die "Can't find __END__ in $filename\n";
	121
	122	$package or die "Can't find 'package Name;' in $filename\n";
	123
	124	my($modpname) = $package; $modpname =~ s#::#/#g;
	125	my($al_idx_file) = "$autodir/$modpname/$IndexFile";
	126
	127	die "Package $package does not match filename $filename"
	128	unless ($filename =~ m/$modpname.pm$/ or
	129	$vms && $filename =~ m/$modpname.pm/i);
	130
	131	if ($check_mod_time){
	132	my($al_ts_time) = (stat("$al_idx_file"))[9] \|\| 1;
	133	if ($al_ts_time >= $pm_mod_time){
	134	print "AutoSplit skipped ($al_idx_file newer that $filename)\n"
	135	if ($Verbose >= 2);
	136	return undef; # one undef, not a list
	137	}
	138	}
	139
	140	my($from) = ($Verbose>=2) ? "$filename => " : "";
	141	print "AutoSplitting $package ($from$autodir/$modpname)\n"
	142	if $Verbose;
	143
	144	unless (-d "$autodir/$modpname"){
	145	local($", @p)="/";
	146	foreach(split(/\//,"$autodir/$modpname")){
	147	push(@p, $_);
42793c05	148	next if -d "@p/";
a0d0e21e	149	mkdir("@p",0777) or die "AutoSplit unable to mkdir @p: $!";
	150	}
	151	}
	152
	153	# We must try to deal with some SVR3 systems with a limit of 14
	154	# characters for file names. Sadly we cannot simply truncate all
	155	# file names to 14 characters on these systems because we must
	156	# create filenames which exactly match the names used by AutoLoader.pm.
	157	# This is a problem because some systems silently truncate the file
	158	# names while others treat long file names as an error.
	159
	160	# We do not yet deal with multiple packages within one file.
	161	# Ideally both of these styles should work.
	162	#
	163	# package NAME;
	164	# __END__
	165	# sub AAA { ... }
	166	# package NAME::option1;
	167	# sub BBB { ... }
	168	# package NAME::option2;
	169	# sub BBB { ... }
	170	#
	171	# package NAME;
	172	# __END__
	173	# sub AAA { ... }
	174	# sub NAME::option1::BBB { ... }
	175	# sub NAME::option2::BBB { ... }
	176	#
	177	# For now both of these produce warnings.
	178
	179	open(OUT,">/dev/null") \|\| open(OUT,">nla0:"); # avoid 'not opened' warning
4633a7c4	180	my(@subnames, %proto);
a0d0e21e	181	while (<IN>) {
	182	if (/^package ([\w:]+)\s*;/) {
	183	warn "package $1; in AutoSplit section ignored. Not currently supported.";
	184	}
4633a7c4	185	if (/^sub\s+([\w:]+)(\s\(.?\))?/) {
a0d0e21e	186	print OUT "1;\n";
4633a7c4	187	my $subname = $1;
4633a7c4	188	$proto{$1} = $2 or '';
a0d0e21e	189	if ($subname =~ m/::/){
	190	warn "subs with package names not currently supported in AutoSplit section";
	191	}
	192	push(@subnames, $subname);
	193	my($lname, $sname) = ($subname, substr($subname,0,$maxflen-3));
	194	my($lpath) = "$autodir/$modpname/$lname.al";
	195	my($spath) = "$autodir/$modpname/$sname.al";
	196	unless(open(OUT, ">$lpath")){
	197	open(OUT, ">$spath") or die "Can't create $spath: $!\n";
	198	push(@names, $sname);
	199	print " writing $spath (with truncated name)\n"
	200	if ($Verbose>=1);
	201	}else{
	202	push(@names, $lname);
	203	print " writing $lpath\n" if ($Verbose>=2);
	204	}
	205	print OUT "# NOTE: Derived from $filename. ",
	206	"Changes made here will be lost.\n";
	207	print OUT "package $package;\n\n";
	208	}
	209	print OUT $_;
	210	}
	211	print OUT "1;\n";
	212	close(OUT);
	213	close(IN);
	214
	215	if (!$keep){ # don't keep any obsolete *.al files in the directory
	216	my(%names);
	217	@names{@names} = @names;
	218	opendir(OUTDIR,"$autodir/$modpname");
	219	foreach(sort readdir(OUTDIR)){
	220	next unless /\.al$/;
	221	my($subname) = m/(.*)\.al$/;
	222	next if $names{substr($subname,0,$maxflen-3)};
	223	my($file) = "$autodir/$modpname/$_";
	224	print " deleting $file\n" if ($Verbose>=2);
f06db76b	225	my($deleted,$thistime); # catch all versions on VMS
	226	do { $deleted += ($thistime = unlink $file) } while ($thistime);
	227	carp "Unable to delete $file: $!" unless $deleted;
a0d0e21e	228	}
	229	closedir(OUTDIR);
	230	}
	231
	232	open(TS,">$al_idx_file") or
	233	carp "AutoSplit: unable to create timestamp file ($al_idx_file): $!";
	234	print TS "# Index created by AutoSplit for $filename (file acts as timestamp)\n";
f06db76b	235	print TS "package $package;\n";
4633a7c4	236	print TS map("sub $_$proto{$_} ;\n", @subnames);
f06db76b	237	print TS "1;\n";
a0d0e21e	238	close(TS);
	239
	240	check_unique($package, $Maxlen, 1, @names);
	241
	242	@names;
	243	}
	244
	245
	246	sub check_unique{
	247	my($module, $maxlen, $warn, @names) = @_;
	248	my(%notuniq) = ();
	249	my(%shorts) = ();
	250	my(@toolong) = grep(length > $maxlen, @names);
	251
	252	foreach(@toolong){
	253	my($trunc) = substr($_,0,$maxlen);
	254	$notuniq{$trunc}=1 if $shorts{$trunc};
	255	$shorts{$trunc} = ($shorts{$trunc}) ? "$shorts{$trunc}, $_" : $_;
	256	}
	257	if (%notuniq && $warn){
	258	print "$module: some names are not unique when truncated to $maxlen characters:\n";
	259	foreach(keys %notuniq){
	260	print " $shorts{$_} truncate to $_\n";
	261	}
	262	}
	263	%notuniq;
	264	}
	265
	266	1;
	267	__END__
	268
	269	# test functions so AutoSplit.pm can be applied to itself:
	270	sub test1{ "test 1\n"; }
	271	sub test2{ "test 2\n"; }
	272	sub test3{ "test 3\n"; }
	273	sub test4{ "test 4\n"; }
	274
	275