PageRenderTime 58ms CodeModel.GetById 10ms app.highlight 42ms RepoModel.GetById 1ms app.codeStats 0ms

/IronPython_Main/Runtime/Tests/LinqDlrTests/testenv/perl/lib/AutoSplit.pm

#
Perl | 488 lines | 402 code | 61 blank | 25 comment | 39 complexity | 99986506396e30cb024b87d6e9b21b25 MD5 | raw file
  1package AutoSplit;
  2
  3use 5.005_64;
  4use Exporter ();
  5use Config qw(%Config);
  6use Carp qw(carp);
  7use File::Basename ();
  8use File::Path qw(mkpath);
  9use File::Spec::Functions qw(curdir catfile);
 10use strict;
 11our($VERSION, @ISA, @EXPORT, @EXPORT_OK, $Verbose, $Keep, $Maxlen,
 12    $CheckForAutoloader, $CheckModTime);
 13
 14$VERSION = "1.0305";
 15@ISA = qw(Exporter);
 16@EXPORT = qw(&autosplit &autosplit_lib_modules);
 17@EXPORT_OK = qw($Verbose $Keep $Maxlen $CheckForAutoloader $CheckModTime);
 18
 19=head1 NAME
 20
 21AutoSplit - split a package for autoloading
 22
 23=head1 SYNOPSIS
 24
 25 autosplit($file, $dir, $keep, $check, $modtime);
 26
 27 autosplit_lib_modules(@modules);
 28
 29=head1 DESCRIPTION
 30
 31This function will split up your program into files that the AutoLoader
 32module can handle. It is used by both the standard perl libraries and by
 33the MakeMaker utility, to automatically configure libraries for autoloading.
 34
 35The C<autosplit> interface splits the specified file into a hierarchy 
 36rooted at the directory C<$dir>. It creates directories as needed to reflect
 37class hierarchy, and creates the file F<autosplit.ix>. This file acts as
 38both forward declaration of all package routines, and as timestamp for the
 39last update of the hierarchy.
 40
 41The remaining three arguments to C<autosplit> govern other options to
 42the autosplitter.
 43
 44=over 2
 45
 46=item $keep
 47
 48If the third argument, I<$keep>, is false, then any
 49pre-existing C<*.al> files in the autoload directory are removed if
 50they are no longer part of the module (obsoleted functions).
 51$keep defaults to 0.
 52
 53=item $check
 54
 55The
 56fourth argument, I<$check>, instructs C<autosplit> to check the module
 57currently being split to ensure that it includes a C<use>
 58specification for the AutoLoader module, and skips the module if
 59AutoLoader is not detected.
 60$check defaults to 1.
 61
 62=item $modtime
 63
 64Lastly, the I<$modtime> argument specifies
 65that C<autosplit> is to check the modification time of the module
 66against that of the C<autosplit.ix> file, and only split the module if
 67it is newer.
 68$modtime defaults to 1.
 69
 70=back
 71
 72Typical use of AutoSplit in the perl MakeMaker utility is via the command-line
 73with:
 74
 75 perl -e 'use AutoSplit; autosplit($ARGV[0], $ARGV[1], 0, 1, 1)'
 76
 77Defined as a Make macro, it is invoked with file and directory arguments;
 78C<autosplit> will split the specified file into the specified directory and
 79delete obsolete C<.al> files, after checking first that the module does use
 80the AutoLoader, and ensuring that the module is not already currently split
 81in its current form (the modtime test).
 82
 83The C<autosplit_lib_modules> form is used in the building of perl. It takes
 84as input a list of files (modules) that are assumed to reside in a directory
 85B<lib> relative to the current directory. Each file is sent to the 
 86autosplitter one at a time, to be split into the directory B<lib/auto>.
 87
 88In both usages of the autosplitter, only subroutines defined following the
 89perl I<__END__> token are split out into separate files. Some
 90routines may be placed prior to this marker to force their immediate loading
 91and parsing.
 92
 93=head2 Multiple packages
 94
 95As of version 1.01 of the AutoSplit module it is possible to have
 96multiple packages within a single file. Both of the following cases
 97are supported:
 98
 99   package NAME;
100   __END__
101   sub AAA { ... }
102   package NAME::option1;
103   sub BBB { ... }
104   package NAME::option2;
105   sub BBB { ... }
106
107   package NAME;
108   __END__
109   sub AAA { ... }
110   sub NAME::option1::BBB { ... }
111   sub NAME::option2::BBB { ... }
112
113=head1 DIAGNOSTICS
114
115C<AutoSplit> will inform the user if it is necessary to create the
116top-level directory specified in the invocation. It is preferred that
117the script or installation process that invokes C<AutoSplit> have
118created the full directory path ahead of time. This warning may
119indicate that the module is being split into an incorrect path.
120
121C<AutoSplit> will warn the user of all subroutines whose name causes
122potential file naming conflicts on machines with drastically limited
123(8 characters or less) file name length. Since the subroutine name is
124used as the file name, these warnings can aid in portability to such
125systems.
126
127Warnings are issued and the file skipped if C<AutoSplit> cannot locate
128either the I<__END__> marker or a "package Name;"-style specification.
129
130C<AutoSplit> will also emit general diagnostics for inability to
131create directories or files.
132
133=cut
134
135# for portability warn about names longer than $maxlen
136$Maxlen  = 8;	# 8 for dos, 11 (14-".al") for SYSVR3
137$Verbose = 1;	# 0=none, 1=minimal, 2=list .al files
138$Keep    = 0;
139$CheckForAutoloader = 1;
140$CheckModTime = 1;
141
142my $IndexFile = "autosplit.ix";	# file also serves as timestamp
143my $maxflen = 255;
144$maxflen = 14 if $Config{'d_flexfnam'} ne 'define';
145if (defined (&Dos::UseLFN)) {
146     $maxflen = Dos::UseLFN() ? 255 : 11;
147}
148my $Is_VMS = ($^O eq 'VMS');
149
150# allow checking for valid ': attrlist' attachments
151my $nested;
152$nested = qr{ \( (?: (?> [^()]+ ) | (??{ $nested }) )* \) }x;
153my $one_attr = qr{ (?> (?! \d) \w+ (?:$nested)? ) (?:\s*\:\s*|\s+(?!\:)) }x;
154my $attr_list = qr{ \s* : \s* (?: $one_attr )* }x;
155
156
157
158sub autosplit{
159    my($file, $autodir,  $keep, $ckal, $ckmt) = @_;
160    # $file    - the perl source file to be split (after __END__)
161    # $autodir - the ".../auto" dir below which to write split subs
162    # Handle optional flags:
163    $keep = $Keep unless defined $keep;
164    $ckal = $CheckForAutoloader unless defined $ckal;
165    $ckmt = $CheckModTime unless defined $ckmt;
166    autosplit_file($file, $autodir, $keep, $ckal, $ckmt);
167}
168
169
170# This function is used during perl building/installation
171# ./miniperl -e 'use AutoSplit; autosplit_lib_modules(@ARGV)' ...
172
173sub autosplit_lib_modules{
174    my(@modules) = @_; # list of Module names
175
176    while(defined($_ = shift @modules)){
177    	while (m#(.*?[^:])::([^:].*)#) { # in case specified as ABC::XYZ
178	    $_ = catfile($1, $2);
179	}
180	s|\\|/|g;		# bug in ksh OS/2
181	s#^lib/##s; # incase specified as lib/*.pm
182	my($lib) = catfile(curdir(), "lib");
183	if ($Is_VMS) { # may need to convert VMS-style filespecs
184	    $lib =~ s#^\[\]#.\/#;
185	}
186	s#^$lib\W+##s; # incase specified as ./lib/*.pm
187	if ($Is_VMS && /[:>\]]/) { # may need to convert VMS-style filespecs
188	    my ($dir,$name) = (/(.*])(.*)/s);
189	    $dir =~ s/.*lib[\.\]]//s;
190	    $dir =~ s#[\.\]]#/#g;
191	    $_ = $dir . $name;
192	}
193	autosplit_file(catfile($lib, $_), catfile($lib, "auto"),
194		       $Keep, $CheckForAutoloader, $CheckModTime);
195    }
196    0;
197}
198
199
200# private functions
201
202sub autosplit_file {
203    my($filename, $autodir, $keep, $check_for_autoloader, $check_mod_time)
204	= @_;
205    my(@outfiles);
206    local($_);
207    local($/) = "\n";
208
209    # where to write output files
210    $autodir ||= catfile(curdir(), "lib", "auto");
211    if ($Is_VMS) {
212	($autodir = VMS::Filespec::unixpath($autodir)) =~ s|/\z||;
213	$filename = VMS::Filespec::unixify($filename); # may have dirs
214    }
215    unless (-d $autodir){
216	mkpath($autodir,0,0755);
217	# We should never need to create the auto dir
218	# here. installperl (or similar) should have done
219	# it. Expecting it to exist is a valuable sanity check against
220	# autosplitting into some random directory by mistake.
221	print "Warning: AutoSplit had to create top-level " .
222	    "$autodir unexpectedly.\n";
223    }
224
225    # allow just a package name to be used
226    $filename .= ".pm" unless ($filename =~ m/\.pm\z/);
227
228    open(IN, "<$filename") or die "AutoSplit: Can't open $filename: $!\n";
229    my($pm_mod_time) = (stat($filename))[9];
230    my($autoloader_seen) = 0;
231    my($in_pod) = 0;
232    my($def_package,$last_package,$this_package,$fnr);
233    while (<IN>) {
234	# Skip pod text.
235	$fnr++;
236	$in_pod = 1 if /^=\w/;
237	$in_pod = 0 if /^=cut/;
238	next if ($in_pod || /^=cut/);
239
240	# record last package name seen
241	$def_package = $1 if (m/^\s*package\s+([\w:]+)\s*;/);
242	++$autoloader_seen if m/^\s*(use|require)\s+AutoLoader\b/;
243	++$autoloader_seen if m/\bISA\s*=.*\bAutoLoader\b/;
244	last if /^__END__/;
245    }
246    if ($check_for_autoloader && !$autoloader_seen){
247	print "AutoSplit skipped $filename: no AutoLoader used\n"
248	    if ($Verbose>=2);
249	return 0;
250    }
251    $_ or die "Can't find __END__ in $filename\n";
252
253    $def_package or die "Can't find 'package Name;' in $filename\n";
254
255    my($modpname) = _modpname($def_package); 
256    if ($Is_VMS) {
257	$modpname = VMS::Filespec::unixify($modpname); # may have dirs
258    }
259
260    # this _has_ to match so we have a reasonable timestamp file
261    die "Package $def_package ($modpname.pm) does not ".
262	"match filename $filename"
263	    unless ($filename =~ m/\Q$modpname.pm\E$/ or
264		    ($^O eq 'dos') or ($^O eq 'MSWin32') or
265	            $Is_VMS && $filename =~ m/$modpname.pm/i);
266
267    my($al_idx_file) = catfile($autodir, $modpname, $IndexFile);
268
269    if ($check_mod_time){
270	my($al_ts_time) = (stat("$al_idx_file"))[9] || 1;
271	if ($al_ts_time >= $pm_mod_time){
272	    print "AutoSplit skipped ($al_idx_file newer than $filename)\n"
273		if ($Verbose >= 2);
274	    return undef;	# one undef, not a list
275	}
276    }
277
278    my($modnamedir) = catfile($autodir, $modpname);
279    print "AutoSplitting $filename ($modnamedir)\n"
280	if $Verbose;
281
282    unless (-d $modnamedir){
283	mkpath($modnamedir,0,0777);
284    }
285
286    # We must try to deal with some SVR3 systems with a limit of 14
287    # characters for file names. Sadly we *cannot* simply truncate all
288    # file names to 14 characters on these systems because we *must*
289    # create filenames which exactly match the names used by AutoLoader.pm.
290    # This is a problem because some systems silently truncate the file
291    # names while others treat long file names as an error.
292
293    my $Is83 = $maxflen==11;  # plain, case INSENSITIVE dos filenames
294
295    my(@subnames, $subname, %proto, %package);
296    my @cache = ();
297    my $caching = 1;
298    $last_package = '';
299    while (<IN>) {
300	$fnr++;
301	$in_pod = 1 if /^=\w/;
302	$in_pod = 0 if /^=cut/;
303	next if ($in_pod || /^=cut/);
304	# the following (tempting) old coding gives big troubles if a
305	# cut is forgotten at EOF:
306	# next if /^=\w/ .. /^=cut/;
307	if (/^package\s+([\w:]+)\s*;/) {
308	    $this_package = $def_package = $1;
309	}
310	if (/^sub\s+([\w:]+)(\s*(?:\(.*?\))?(?:$attr_list)?)/) {
311	    print OUT "# end of $last_package\::$subname\n1;\n"
312		if $last_package;
313	    $subname = $1;
314	    my $proto = $2 || '';
315	    if ($subname =~ s/(.*):://){
316		$this_package = $1;
317	    } else {
318		$this_package = $def_package;
319	    }
320	    my $fq_subname = "$this_package\::$subname";
321	    $package{$fq_subname} = $this_package;
322	    $proto{$fq_subname} = $proto;
323	    push(@subnames, $fq_subname);
324	    my($lname, $sname) = ($subname, substr($subname,0,$maxflen-3));
325	    $modpname = _modpname($this_package);
326    	    my($modnamedir) = catfile($autodir, $modpname);
327	    mkpath($modnamedir,0,0777);
328	    my($lpath) = catfile($modnamedir, "$lname.al");
329	    my($spath) = catfile($modnamedir, "$sname.al");
330	    my $path;
331	    if (!$Is83 and open(OUT, ">$lpath")){
332	        $path=$lpath;
333		print "  writing $lpath\n" if ($Verbose>=2);
334	    } else {
335		open(OUT, ">$spath") or die "Can't create $spath: $!\n";
336		$path=$spath;
337		print "  writing $spath (with truncated name)\n"
338			if ($Verbose>=1);
339	    }
340	    push(@outfiles, $path);
341	    my $lineno = $fnr - @cache;
342	    print OUT <<EOT;
343# NOTE: Derived from $filename.
344# Changes made here will be lost when autosplit is run again.
345# See AutoSplit.pm.
346package $this_package;
347
348#line $lineno "$filename (autosplit into $path)"
349EOT
350	    print OUT @cache;
351	    @cache = ();
352	    $caching = 0;
353	}
354	if($caching) {
355	    push(@cache, $_) if @cache || /\S/;
356	} else {
357	    print OUT $_;
358	}
359	if(/^\}/) {
360	    if($caching) {
361		print OUT @cache;
362		@cache = ();
363	    }
364	    print OUT "\n";
365	    $caching = 1;
366	}
367	$last_package = $this_package if defined $this_package;
368    }
369    if ($subname) {
370	print OUT @cache,"1;\n# end of $last_package\::$subname\n";
371	close(OUT);
372    }
373    close(IN);
374    
375    if (!$keep){  # don't keep any obsolete *.al files in the directory
376	my(%outfiles);
377	# @outfiles{@outfiles} = @outfiles;
378	# perl downcases all filenames on VMS (which upcases all filenames) so
379	# we'd better downcase the sub name list too, or subs with upper case
380	# letters in them will get their .al files deleted right after they're
381	# created. (The mixed case sub name won't match the all-lowercase
382	# filename, and so be cleaned up as a scrap file)
383	if ($Is_VMS or $Is83) {
384	    %outfiles = map {lc($_) => lc($_) } @outfiles;
385	} else {
386	    @outfiles{@outfiles} = @outfiles;
387	}  
388	my(%outdirs,@outdirs);
389	for (@outfiles) {
390	    $outdirs{File::Basename::dirname($_)}||=1;
391	}
392	for my $dir (keys %outdirs) {
393	    opendir(OUTDIR,$dir);
394	    foreach (sort readdir(OUTDIR)){
395		next unless /\.al\z/;
396		my($file) = catfile($dir, $_);
397		$file = lc $file if $Is83 or $Is_VMS;
398		next if $outfiles{$file};
399		print "  deleting $file\n" if ($Verbose>=2);
400		my($deleted,$thistime);  # catch all versions on VMS
401		do { $deleted += ($thistime = unlink $file) } while ($thistime);
402		carp "Unable to delete $file: $!" unless $deleted;
403	    }
404	    closedir(OUTDIR);
405	}
406    }
407
408    open(TS,">$al_idx_file") or
409	carp "AutoSplit: unable to create timestamp file ($al_idx_file): $!";
410    print TS "# Index created by AutoSplit for $filename\n";
411    print TS "#    (file acts as timestamp)\n";
412    $last_package = '';
413    for my $fqs (@subnames) {
414	my($subname) = $fqs;
415	$subname =~ s/.*:://;
416	print TS "package $package{$fqs};\n"
417	    unless $last_package eq $package{$fqs};
418	print TS "sub $subname $proto{$fqs};\n";
419	$last_package = $package{$fqs};
420    }
421    print TS "1;\n";
422    close(TS);
423
424    _check_unique($filename, $Maxlen, 1, @outfiles);
425
426    @outfiles;
427}
428
429sub _modpname ($) {
430    my($package) = @_;
431    my $modpname = $package;
432    if ($^O eq 'MSWin32') {
433	$modpname =~ s#::#\\#g; 
434    } else {
435    	while ($modpname =~ m#(.*?[^:])::([^:].*)#) {
436	    $modpname = catfile($1, $2);
437	}
438    }
439    $modpname;
440}
441
442sub _check_unique {
443    my($filename, $maxlen, $warn, @outfiles) = @_;
444    my(%notuniq) = ();
445    my(%shorts)  = ();
446    my(@toolong) = grep(
447			length(File::Basename::basename($_))
448			> $maxlen,
449			@outfiles
450		       );
451
452    foreach (@toolong){
453	my($dir) = File::Basename::dirname($_);
454	my($file) = File::Basename::basename($_);
455	my($trunc) = substr($file,0,$maxlen);
456	$notuniq{$dir}{$trunc} = 1 if $shorts{$dir}{$trunc};
457	$shorts{$dir}{$trunc} = $shorts{$dir}{$trunc} ?
458	    "$shorts{$dir}{$trunc}, $file" : $file;
459    }
460    if (%notuniq && $warn){
461	print "$filename: some names are not unique when " .
462	    "truncated to $maxlen characters:\n";
463	foreach my $dir (sort keys %notuniq){
464	    print " directory $dir:\n";
465	    foreach my $trunc (sort keys %{$notuniq{$dir}}) {
466		print "  $shorts{$dir}{$trunc} truncate to $trunc\n";
467	    }
468	}
469    }
470}
471
4721;
473__END__
474
475# test functions so AutoSplit.pm can be applied to itself:
476sub test1 ($)   { "test 1\n"; }
477sub test2 ($$)  { "test 2\n"; }
478sub test3 ($$$) { "test 3\n"; }
479sub testtesttesttest4_1  { "test 4\n"; }
480sub testtesttesttest4_2  { "duplicate test 4\n"; }
481sub Just::Another::test5 { "another test 5\n"; }
482sub test6       { return join ":", __FILE__,__LINE__; }
483package Yet::Another::AutoSplit;
484sub testtesttesttest4_1 ($)  { "another test 4\n"; }
485sub testtesttesttest4_2 ($$) { "another duplicate test 4\n"; }
486package Yet::More::Attributes;
487sub test_a1 ($) : locked :locked { 1; }
488sub test_a2 : locked { 1; }