1package AutoSplit;
2
3use Exporter ();
4use Config qw(%Config);
5use File::Basename ();
6use File::Path qw(mkpath);
7use File::Spec::Functions qw(curdir catfile catdir);
8use strict;
9our($VERSION, @ISA, @EXPORT, @EXPORT_OK, $Verbose, $Keep, $Maxlen,
10    $CheckForAutoloader, $CheckModTime);
11
12$VERSION = "1.06";
13@ISA = qw(Exporter);
14@EXPORT = qw(&autosplit &autosplit_lib_modules);
15@EXPORT_OK = qw($Verbose $Keep $Maxlen $CheckForAutoloader $CheckModTime);
16
17=head1 NAME
18
19AutoSplit - split a package for autoloading
20
21=head1 SYNOPSIS
22
23 autosplit($file, $dir, $keep, $check, $modtime);
24
25 autosplit_lib_modules(@modules);
26
27=head1 DESCRIPTION
28
29This function will split up your program into files that the AutoLoader
30module can handle. It is used by both the standard perl libraries and by
31the MakeMaker utility, to automatically configure libraries for autoloading.
32
33The C<autosplit> interface splits the specified file into a hierarchy
34rooted at the directory C<$dir>. It creates directories as needed to reflect
35class hierarchy, and creates the file F<autosplit.ix>. This file acts as
36both forward declaration of all package routines, and as timestamp for the
37last update of the hierarchy.
38
39The remaining three arguments to C<autosplit> govern other options to
40the autosplitter.
41
42=over 2
43
44=item $keep
45
46If the third argument, I<$keep>, is false, then any
47pre-existing C<*.al> files in the autoload directory are removed if
48they are no longer part of the module (obsoleted functions).
49$keep defaults to 0.
50
51=item $check
52
53The
54fourth argument, I<$check>, instructs C<autosplit> to check the module
55currently being split to ensure that it includes a C<use>
56specification for the AutoLoader module, and skips the module if
57AutoLoader is not detected.
58$check defaults to 1.
59
60=item $modtime
61
62Lastly, the I<$modtime> argument specifies
63that C<autosplit> is to check the modification time of the module
64against that of the C<autosplit.ix> file, and only split the module if
65it is newer.
66$modtime defaults to 1.
67
68=back
69
70Typical use of AutoSplit in the perl MakeMaker utility is via the command-line
71with:
72
73 perl -e 'use AutoSplit; autosplit($ARGV[0], $ARGV[1], 0, 1, 1)'
74
75Defined as a Make macro, it is invoked with file and directory arguments;
76C<autosplit> will split the specified file into the specified directory and
77delete obsolete C<.al> files, after checking first that the module does use
78the AutoLoader, and ensuring that the module is not already currently split
79in its current form (the modtime test).
80
81The C<autosplit_lib_modules> form is used in the building of perl. It takes
82as input a list of files (modules) that are assumed to reside in a directory
83B<lib> relative to the current directory. Each file is sent to the
84autosplitter one at a time, to be split into the directory B<lib/auto>.
85
86In both usages of the autosplitter, only subroutines defined following the
87perl I<__END__> token are split out into separate files. Some
88routines may be placed prior to this marker to force their immediate loading
89and parsing.
90
91=head2 Multiple packages
92
93As of version 1.01 of the AutoSplit module it is possible to have
94multiple packages within a single file. Both of the following cases
95are supported:
96
97   package NAME;
98   __END__
99   sub AAA { ... }
100   package NAME::option1;
101   sub BBB { ... }
102   package NAME::option2;
103   sub BBB { ... }
104
105   package NAME;
106   __END__
107   sub AAA { ... }
108   sub NAME::option1::BBB { ... }
109   sub NAME::option2::BBB { ... }
110
111=head1 DIAGNOSTICS
112
113C<AutoSplit> will inform the user if it is necessary to create the
114top-level directory specified in the invocation. It is preferred that
115the script or installation process that invokes C<AutoSplit> have
116created the full directory path ahead of time. This warning may
117indicate that the module is being split into an incorrect path.
118
119C<AutoSplit> will warn the user of all subroutines whose name causes
120potential file naming conflicts on machines with drastically limited
121(8 characters or less) file name length. Since the subroutine name is
122used as the file name, these warnings can aid in portability to such
123systems.
124
125Warnings are issued and the file skipped if C<AutoSplit> cannot locate
126either the I<__END__> marker or a "package Name;"-style specification.
127
128C<AutoSplit> will also emit general diagnostics for inability to
129create directories or files.
130
131=head1 AUTHOR
132
133C<AutoSplit> is maintained by the perl5-porters. Please direct
134any questions to the canonical mailing list. Anything that
135is applicable to the CPAN release can be sent to its maintainer,
136though.
137
138Author and Maintainer: The Perl5-Porters <perl5-porters@perl.org>
139
140Maintainer of the CPAN release: Steffen Mueller <smueller@cpan.org>
141
142=head1 COPYRIGHT AND LICENSE
143
144This package has been part of the perl core since the first release
145of perl5. It has been released separately to CPAN so older installations
146can benefit from bug fixes.
147
148This package has the same copyright and license as the perl core:
149
150             Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999,
151        2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
152        by Larry Wall and others
153
154			    All rights reserved.
155
156    This program is free software; you can redistribute it and/or modify
157    it under the terms of either:
158
159	a) the GNU General Public License as published by the Free
160	Software Foundation; either version 1, or (at your option) any
161	later version, or
162
163	b) the "Artistic License" which comes with this Kit.
164
165    This program is distributed in the hope that it will be useful,
166    but WITHOUT ANY WARRANTY; without even the implied warranty of
167    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See either
168    the GNU General Public License or the Artistic License for more details.
169
170    You should have received a copy of the Artistic License with this
171    Kit, in the file named "Artistic".  If not, I'll be glad to provide one.
172
173    You should also have received a copy of the GNU General Public License
174    along with this program in the file named "Copying". If not, write to the
175    Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
176    02111-1307, USA or visit their web page on the internet at
177    http://www.gnu.org/copyleft/gpl.html.
178
179    For those of you that choose to use the GNU General Public License,
180    my interpretation of the GNU General Public License is that no Perl
181    script falls under the terms of the GPL unless you explicitly put
182    said script under the terms of the GPL yourself.  Furthermore, any
183    object code linked with perl does not automatically fall under the
184    terms of the GPL, provided such object code only adds definitions
185    of subroutines and variables, and does not otherwise impair the
186    resulting interpreter from executing any standard Perl script.  I
187    consider linking in C subroutines in this manner to be the moral
188    equivalent of defining subroutines in the Perl language itself.  You
189    may sell such an object file as proprietary provided that you provide
190    or offer to provide the Perl source, as specified by the GNU General
191    Public License.  (This is merely an alternate way of specifying input
192    to the program.)  You may also sell a binary produced by the dumping of
193    a running Perl script that belongs to you, provided that you provide or
194    offer to provide the Perl source as specified by the GPL.  (The
195    fact that a Perl interpreter and your code are in the same binary file
196    is, in this case, a form of mere aggregation.)  This is my interpretation
197    of the GPL.  If you still have concerns or difficulties understanding
198    my intent, feel free to contact me.  Of course, the Artistic License
199    spells all this out for your protection, so you may prefer to use that.
200
201=cut
202
203# for portability warn about names longer than $maxlen
204$Maxlen  = 8;	# 8 for dos, 11 (14-".al") for SYSVR3
205$Verbose = 1;	# 0=none, 1=minimal, 2=list .al files
206$Keep    = 0;
207$CheckForAutoloader = 1;
208$CheckModTime = 1;
209
210my $IndexFile = "autosplit.ix";	# file also serves as timestamp
211my $maxflen = 255;
212$maxflen = 14 if $Config{'d_flexfnam'} ne 'define';
213if (defined (&Dos::UseLFN)) {
214     $maxflen = Dos::UseLFN() ? 255 : 11;
215}
216my $Is_VMS = ($^O eq 'VMS');
217
218# allow checking for valid ': attrlist' attachments.
219# extra jugglery required to support both 5.8 and 5.9/5.10 features
220# (support for 5.8 required for cross-compiling environments)
221
222my $attr_list =
223  $] >= 5.009005 ?
224  eval <<'__QR__'
225  qr{
226    \s* : \s*
227    (?:
228	# one attribute
229	(?> # no backtrack
230	    (?! \d) \w+
231	    (?<nested> \( (?: [^()]++ | (?&nested)++ )*+ \) ) ?
232	)
233	(?: \s* : \s* | \s+ (?! :) )
234    )*
235  }x
236__QR__
237  :
238  do {
239    # In pre-5.9.5 world we have to do dirty tricks.
240    # (we use 'our' rather than 'my' here, due to the rather complex and buggy
241    # behaviour of lexicals with qr// and (??{$lex}) )
242    our $trick1; # yes, cannot our and assign at the same time.
243    $trick1 = qr{ \( (?: (?> [^()]+ ) | (??{ $trick1 }) )* \) }x;
244    our $trick2 = qr{ (?> (?! \d) \w+ (?:$trick1)? ) (?:\s*\:\s*|\s+(?!\:)) }x;
245    qr{ \s* : \s* (?: $trick2 )* }x;
246  };
247
248sub autosplit{
249    my($file, $autodir,  $keep, $ckal, $ckmt) = @_;
250    # $file    - the perl source file to be split (after __END__)
251    # $autodir - the ".../auto" dir below which to write split subs
252    # Handle optional flags:
253    $keep = $Keep unless defined $keep;
254    $ckal = $CheckForAutoloader unless defined $ckal;
255    $ckmt = $CheckModTime unless defined $ckmt;
256    autosplit_file($file, $autodir, $keep, $ckal, $ckmt);
257}
258
259sub carp{
260    require Carp;
261    goto &Carp::carp;
262}
263
264# This function is used during perl building/installation
265# ./miniperl -e 'use AutoSplit; autosplit_lib_modules(@ARGV)' ...
266
267sub autosplit_lib_modules {
268    my(@modules) = @_; # list of Module names
269    local $_; # Avoid clobber.
270    while (defined($_ = shift @modules)) {
271	while (m#([^:]+)::([^:].*)#) { # in case specified as ABC::XYZ
272	    $_ = catfile($1, $2);
273	}
274	s|\\|/|g;		# bug in ksh OS/2
275	s#^lib/##s; # incase specified as lib/*.pm
276	my($lib) = catfile(curdir(), "lib");
277	if ($Is_VMS) { # may need to convert VMS-style filespecs
278	    $lib =~ s#^\[\]#.\/#;
279	}
280	s#^$lib\W+##s; # incase specified as ./lib/*.pm
281	if ($Is_VMS && /[:>\]]/) { # may need to convert VMS-style filespecs
282	    my ($dir,$name) = (/(.*])(.*)/s);
283	    $dir =~ s/.*lib[\.\]]//s;
284	    $dir =~ s#[\.\]]#/#g;
285	    $_ = $dir . $name;
286	}
287	autosplit_file(catfile($lib, $_), catfile($lib, "auto"),
288		       $Keep, $CheckForAutoloader, $CheckModTime);
289    }
290    0;
291}
292
293
294# private functions
295
296my $self_mod_time = (stat __FILE__)[9];
297
298sub autosplit_file {
299    my($filename, $autodir, $keep, $check_for_autoloader, $check_mod_time)
300	= @_;
301    my(@outfiles);
302    local($_);
303    local($/) = "\n";
304
305    # where to write output files
306    $autodir ||= catfile(curdir(), "lib", "auto");
307    if ($Is_VMS) {
308	($autodir = VMS::Filespec::unixpath($autodir)) =~ s|/\z||;
309	$filename = VMS::Filespec::unixify($filename); # may have dirs
310    }
311    unless (-d $autodir){
312	mkpath($autodir,0,0755);
313	# We should never need to create the auto dir
314	# here. installperl (or similar) should have done
315	# it. Expecting it to exist is a valuable sanity check against
316	# autosplitting into some random directory by mistake.
317	print "Warning: AutoSplit had to create top-level " .
318	    "$autodir unexpectedly.\n";
319    }
320
321    # allow just a package name to be used
322    $filename .= ".pm" unless ($filename =~ m/\.pm\z/);
323
324    open(my $in, "<$filename") or die "AutoSplit: Can't open $filename: $!\n";
325    my($pm_mod_time) = (stat($filename))[9];
326    my($autoloader_seen) = 0;
327    my($in_pod) = 0;
328    my($def_package,$last_package,$this_package,$fnr);
329    while (<$in>) {
330	# Skip pod text.
331	$fnr++;
332	$in_pod = 1 if /^=\w/;
333	$in_pod = 0 if /^=cut/;
334	next if ($in_pod || /^=cut/);
335        next if /^\s*#/;
336
337	# record last package name seen
338	$def_package = $1 if (m/^\s*package\s+([\w:]+)\s*;/);
339	++$autoloader_seen if m/^\s*(use|require)\s+AutoLoader\b/;
340	++$autoloader_seen if m/\bISA\s*=.*\bAutoLoader\b/;
341	last if /^__END__/;
342    }
343    if ($check_for_autoloader && !$autoloader_seen){
344	print "AutoSplit skipped $filename: no AutoLoader used\n"
345	    if ($Verbose>=2);
346	return 0;
347    }
348    $_ or die "Can't find __END__ in $filename\n";
349
350    $def_package or die "Can't find 'package Name;' in $filename\n";
351
352    my($modpname) = _modpname($def_package);
353
354    # this _has_ to match so we have a reasonable timestamp file
355    die "Package $def_package ($modpname.pm) does not ".
356	"match filename $filename"
357	    unless ($filename =~ m/\Q$modpname.pm\E$/ or
358		    ($^O eq 'dos') or ($^O eq 'MSWin32') or ($^O eq 'NetWare') or
359	            $Is_VMS && $filename =~ m/$modpname.pm/i);
360
361    my($al_idx_file) = catfile($autodir, $modpname, $IndexFile);
362
363    if ($check_mod_time){
364	my($al_ts_time) = (stat("$al_idx_file"))[9] || 1;
365	if ($al_ts_time >= $pm_mod_time and
366	    $al_ts_time >= $self_mod_time){
367	    print "AutoSplit skipped ($al_idx_file newer than $filename)\n"
368		if ($Verbose >= 2);
369	    return undef;	# one undef, not a list
370	}
371    }
372
373    my($modnamedir) = catdir($autodir, $modpname);
374    print "AutoSplitting $filename ($modnamedir)\n"
375	if $Verbose;
376
377    unless (-d $modnamedir){
378	mkpath($modnamedir,0,0777);
379    }
380
381    # We must try to deal with some SVR3 systems with a limit of 14
382    # characters for file names. Sadly we *cannot* simply truncate all
383    # file names to 14 characters on these systems because we *must*
384    # create filenames which exactly match the names used by AutoLoader.pm.
385    # This is a problem because some systems silently truncate the file
386    # names while others treat long file names as an error.
387
388    my $Is83 = $maxflen==11;  # plain, case INSENSITIVE dos filenames
389
390    my(@subnames, $subname, %proto, %package);
391    my @cache = ();
392    my $caching = 1;
393    $last_package = '';
394    my $out;
395    while (<$in>) {
396	$fnr++;
397	$in_pod = 1 if /^=\w/;
398	$in_pod = 0 if /^=cut/;
399	next if ($in_pod || /^=cut/);
400	# the following (tempting) old coding gives big troubles if a
401	# cut is forgotten at EOF:
402	# next if /^=\w/ .. /^=cut/;
403	if (/^package\s+([\w:]+)\s*;/) {
404	    $this_package = $def_package = $1;
405	}
406
407	if (/^sub\s+([\w:]+)(\s*(?:\(.*?\))?(?:$attr_list)?)/) {
408	    print $out "# end of $last_package\::$subname\n1;\n"
409		if $last_package;
410	    $subname = $1;
411	    my $proto = $2 || '';
412	    if ($subname =~ s/(.*):://){
413		$this_package = $1;
414	    } else {
415		$this_package = $def_package;
416	    }
417	    my $fq_subname = "$this_package\::$subname";
418	    $package{$fq_subname} = $this_package;
419	    $proto{$fq_subname} = $proto;
420	    push(@subnames, $fq_subname);
421	    my($lname, $sname) = ($subname, substr($subname,0,$maxflen-3));
422	    $modpname = _modpname($this_package);
423            my($modnamedir) = catdir($autodir, $modpname);
424	    mkpath($modnamedir,0,0777);
425	    my($lpath) = catfile($modnamedir, "$lname.al");
426	    my($spath) = catfile($modnamedir, "$sname.al");
427	    my $path;
428
429	    if (!$Is83 and open($out, ">$lpath")){
430	        $path=$lpath;
431		print "  writing $lpath\n" if ($Verbose>=2);
432	    } else {
433		open($out, ">$spath") or die "Can't create $spath: $!\n";
434		$path=$spath;
435		print "  writing $spath (with truncated name)\n"
436			if ($Verbose>=1);
437	    }
438	    push(@outfiles, $path);
439	    my $lineno = $fnr - @cache;
440	    print $out <<EOT;
441# NOTE: Derived from $filename.
442# Changes made here will be lost when autosplit is run again.
443# See AutoSplit.pm.
444package $this_package;
445
446#line $lineno "$filename (autosplit into $path)"
447EOT
448	    print $out @cache;
449	    @cache = ();
450	    $caching = 0;
451	}
452	if($caching) {
453	    push(@cache, $_) if @cache || /\S/;
454	} else {
455	    print $out $_;
456	}
457	if(/^\}/) {
458	    if($caching) {
459		print $out @cache;
460		@cache = ();
461	    }
462	    print $out "\n";
463	    $caching = 1;
464	}
465	$last_package = $this_package if defined $this_package;
466    }
467    if ($subname) {
468	print $out @cache,"1;\n# end of $last_package\::$subname\n";
469	close($out);
470    }
471    close($in);
472
473    if (!$keep){  # don't keep any obsolete *.al files in the directory
474	my(%outfiles);
475	# @outfiles{@outfiles} = @outfiles;
476	# perl downcases all filenames on VMS (which upcases all filenames) so
477	# we'd better downcase the sub name list too, or subs with upper case
478	# letters in them will get their .al files deleted right after they're
479	# created. (The mixed case sub name won't match the all-lowercase
480	# filename, and so be cleaned up as a scrap file)
481	if ($Is_VMS or $Is83) {
482	    %outfiles = map {lc($_) => lc($_) } @outfiles;
483	} else {
484	    @outfiles{@outfiles} = @outfiles;
485	}
486	my(%outdirs,@outdirs);
487	for (@outfiles) {
488	    $outdirs{File::Basename::dirname($_)}||=1;
489	}
490	for my $dir (keys %outdirs) {
491	    opendir(my $outdir,$dir);
492	    foreach (sort readdir($outdir)){
493		next unless /\.al\z/;
494		my($file) = catfile($dir, $_);
495		$file = lc $file if $Is83 or $Is_VMS;
496		next if $outfiles{$file};
497		print "  deleting $file\n" if ($Verbose>=2);
498		my($deleted,$thistime);  # catch all versions on VMS
499		do { $deleted += ($thistime = unlink $file) } while ($thistime);
500		carp ("Unable to delete $file: $!") unless $deleted;
501	    }
502	    closedir($outdir);
503	}
504    }
505
506    open(my $ts,">$al_idx_file") or
507	carp ("AutoSplit: unable to create timestamp file ($al_idx_file): $!");
508    print $ts "# Index created by AutoSplit for $filename\n";
509    print $ts "#    (file acts as timestamp)\n";
510    $last_package = '';
511    for my $fqs (@subnames) {
512	my($subname) = $fqs;
513	$subname =~ s/.*:://;
514	print $ts "package $package{$fqs};\n"
515	    unless $last_package eq $package{$fqs};
516	print $ts "sub $subname $proto{$fqs};\n";
517	$last_package = $package{$fqs};
518    }
519    print $ts "1;\n";
520    close($ts);
521
522    _check_unique($filename, $Maxlen, 1, @outfiles);
523
524    @outfiles;
525}
526
527sub _modpname ($) {
528    my($package) = @_;
529    my $modpname = $package;
530    if ($^O eq 'MSWin32') {
531	$modpname =~ s#::#\\#g;
532    } else {
533	my @modpnames = ();
534	while ($modpname =~ m#(.*?[^:])::([^:].*)#) {
535	       push @modpnames, $1;
536	       $modpname = $2;
537         }
538	$modpname = catfile(@modpnames, $modpname);
539    }
540    if ($Is_VMS) {
541        $modpname = VMS::Filespec::unixify($modpname); # may have dirs
542    }
543    $modpname;
544}
545
546sub _check_unique {
547    my($filename, $maxlen, $warn, @outfiles) = @_;
548    my(%notuniq) = ();
549    my(%shorts)  = ();
550    my(@toolong) = grep(
551			length(File::Basename::basename($_))
552			> $maxlen,
553			@outfiles
554		       );
555
556    foreach (@toolong){
557	my($dir) = File::Basename::dirname($_);
558	my($file) = File::Basename::basename($_);
559	my($trunc) = substr($file,0,$maxlen);
560	$notuniq{$dir}{$trunc} = 1 if $shorts{$dir}{$trunc};
561	$shorts{$dir}{$trunc} = $shorts{$dir}{$trunc} ?
562	    "$shorts{$dir}{$trunc}, $file" : $file;
563    }
564    if (%notuniq && $warn){
565	print "$filename: some names are not unique when " .
566	    "truncated to $maxlen characters:\n";
567	foreach my $dir (sort keys %notuniq){
568	    print " directory $dir:\n";
569	    foreach my $trunc (sort keys %{$notuniq{$dir}}) {
570		print "  $shorts{$dir}{$trunc} truncate to $trunc\n";
571	    }
572	}
573    }
574}
575
5761;
577__END__
578
579# test functions so AutoSplit.pm can be applied to itself:
580sub test1 ($)   { "test 1\n"; }
581sub test2 ($$)  { "test 2\n"; }
582sub test3 ($$$) { "test 3\n"; }
583sub testtesttesttest4_1  { "test 4\n"; }
584sub testtesttesttest4_2  { "duplicate test 4\n"; }
585sub Just::Another::test5 { "another test 5\n"; }
586sub test6       { return join ":", __FILE__,__LINE__; }
587package Yet::Another::AutoSplit;
588sub testtesttesttest4_1 ($)  { "another test 4\n"; }
589sub testtesttesttest4_2 ($$) { "another duplicate test 4\n"; }
590package Yet::More::Attributes;
591sub test_a1 ($) : locked :locked { 1; }
592sub test_a2 : locked { 1; }
593