[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 SYNOPSIS

 perl -e 'use AutoSplit; autosplit_modules(@ARGV)'  ...

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