X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FAutoSplit.pm;h=41d5489531827a4856f5916702491d237f855605;hb=cc31225e4d4aa42bdd0b59e2f2e27664df411220;hp=78fa59beaf095c6e1612217952e1402b3c45a7b3;hpb=6e19ff93dfe8cda893891d183baba8b8c8502350;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/lib/AutoSplit.pm b/lib/AutoSplit.pm
index 78fa59b..41d5489 100644
--- a/lib/AutoSplit.pm
+++ b/lib/AutoSplit.pm
@@ -1,17 +1,16 @@
 package AutoSplit;
 
+use 5.005_64;
 use Exporter ();
 use Config qw(%Config);
 use Carp qw(carp);
 use File::Basename ();
 use File::Path qw(mkpath);
 use strict;
-use vars qw(
-	    $VERSION @ISA @EXPORT @EXPORT_OK
-	    $Verbose $Keep $Maxlen $CheckForAutoloader $CheckModTime
-	   );
+our($VERSION, @ISA, @EXPORT, @EXPORT_OK, $Verbose, $Keep, $Maxlen,
+    $CheckForAutoloader, $CheckModTime);
 
-$VERSION = "1.0303";
+$VERSION = "1.0305";
 @ISA = qw(Exporter);
 @EXPORT = qw(&autosplit &autosplit_lib_modules);
 @EXPORT_OK = qw($Verbose $Keep $Maxlen $CheckForAutoloader $CheckModTime);
@@ -147,6 +146,13 @@ if (defined (&Dos::UseLFN)) {
 }
 my $Is_VMS = ($^O eq 'VMS');
 
+# allow checking for valid ': attrlist' attachments
+my $nested;
+$nested = qr{ \( (?: (?> [^()]+ ) | (?p{ $nested }) )* \) }x;
+my $one_attr = qr{ (?> (?! \d) \w+ (?:$nested)? ) (?:\s*\:\s*|\s+(?!\:)) }x;
+my $attr_list = qr{ \s* : \s* (?: $one_attr )* }x;
+
+
 
 sub autosplit{
     my($file, $autodir,  $keep, $ckal, $ckmt) = @_;
@@ -188,7 +194,7 @@ sub autosplit_lib_modules{
 sub autosplit_file {
     my($filename, $autodir, $keep, $check_for_autoloader, $check_mod_time)
 	= @_;
-    my(%outfiles);
+    my(@outfiles);
     local($_);
     local($/) = "\n";
 
@@ -219,7 +225,7 @@ sub autosplit_file {
     while (<IN>) {
 	# Skip pod text.
 	$fnr++;
-	$in_pod = 1 if /^=/;
+	$in_pod = 1 if /^=\w/;
 	$in_pod = 0 if /^=cut/;
 	next if ($in_pod || /^=cut/);
 
@@ -280,7 +286,7 @@ sub autosplit_file {
     $last_package = '';
     while (<IN>) {
 	$fnr++;
-	$in_pod = 1 if /^=/;
+	$in_pod = 1 if /^=\w/;
 	$in_pod = 0 if /^=cut/;
 	next if ($in_pod || /^=cut/);
 	# the following (tempting) old coding gives big troubles if a
@@ -289,7 +295,7 @@ sub autosplit_file {
 	if (/^package\s+([\w:]+)\s*;/) {
 	    $this_package = $def_package = $1;
 	}
-	if (/^sub\s+([\w:]+)(\s*\(.*?\))?/) {
+	if (/^sub\s+([\w:]+)(\s*(?:\(.*?\))?(?:$attr_list)?)/) {
 	    print OUT "# end of $last_package\::$subname\n1;\n"
 		if $last_package;
 	    $subname = $1;
@@ -311,24 +317,14 @@ sub autosplit_file {
 	    my $path;
 	    if (!$Is83 and open(OUT, ">$lpath")){
 	        $path=$lpath;
-		# perl downcases all filenames on VMS (which upcases all filenames) so
-		# we'd better downcase the sub name list too, or subs with upper case
-		# letters in them will get their .al files deleted right after they're
-		# created. (The mixed case sub name won't match the all-lowercase
-		# filename, and so be cleaned up as a scrap file)
-		my $opath = ($Is_VMS or $Is83) ? lc($path) : $path;
-		$outfiles{$opath} = $path;
 		print "  writing $lpath\n" if ($Verbose>=2);
 	    } else {
+		open(OUT, ">$spath") or die "Can't create $spath: $!\n";
 		$path=$spath;
-		# same as above comment
-		my $opath = ($Is_VMS or $Is83) ? lc($path) : $path;
-		my $mode = exists $outfiles{$opath} ? ">>" : ">";
-		open(OUT, "$mode$spath") or die "Can't create $spath: $!\n";
-		$outfiles{$opath} = $path;
 		print "  writing $spath (with truncated name)\n"
 			if ($Verbose>=1);
 	    }
+	    push(@outfiles, $path);
 	    print OUT <<EOT;
 # NOTE: Derived from $filename.
 # Changes made here will be lost when autosplit again.
@@ -356,13 +352,27 @@ EOT
 	}
 	$last_package = $this_package if defined $this_package;
     }
-    print OUT @cache,"1;\n# end of $last_package\::$subname\n";
-    close(OUT);
+    if ($subname) {
+	print OUT @cache,"1;\n# end of $last_package\::$subname\n";
+	close(OUT);
+    }
     close(IN);
     
     if (!$keep){  # don't keep any obsolete *.al files in the directory
+	my(%outfiles);
+	# @outfiles{@outfiles} = @outfiles;
+	# perl downcases all filenames on VMS (which upcases all filenames) so
+	# we'd better downcase the sub name list too, or subs with upper case
+	# letters in them will get their .al files deleted right after they're
+	# created. (The mixed case sub name won't match the all-lowercase
+	# filename, and so be cleaned up as a scrap file)
+	if ($Is_VMS or $Is83) {
+	    %outfiles = map {lc($_) => lc($_) } @outfiles;
+	} else {
+	    @outfiles{@outfiles} = @outfiles;
+	}  
 	my(%outdirs,@outdirs);
-	for (values %outfiles) {
+	for (@outfiles) {
 	    $outdirs{File::Basename::dirname($_)}||=1;
 	}
 	for my $dir (keys %outdirs) {
@@ -397,7 +407,9 @@ EOT
     print TS "1;\n";
     close(TS);
 
-    values %outfiles;
+    _check_unique($filename, $Maxlen, 1, @outfiles);
+
+    @outfiles;
 }
 
 sub _modpname ($) {
@@ -411,6 +423,36 @@ sub _modpname ($) {
     $modpname;
 }
 
+sub _check_unique {
+    my($filename, $maxlen, $warn, @outfiles) = @_;
+    my(%notuniq) = ();
+    my(%shorts)  = ();
+    my(@toolong) = grep(
+			length(File::Basename::basename($_))
+			> $maxlen,
+			@outfiles
+		       );
+
+    foreach (@toolong){
+	my($dir) = File::Basename::dirname($_);
+	my($file) = File::Basename::basename($_);
+	my($trunc) = substr($file,0,$maxlen);
+	$notuniq{$dir}{$trunc} = 1 if $shorts{$dir}{$trunc};
+	$shorts{$dir}{$trunc} = $shorts{$dir}{$trunc} ?
+	    "$shorts{$dir}{$trunc}, $file" : $file;
+    }
+    if (%notuniq && $warn){
+	print "$filename: some names are not unique when " .
+	    "truncated to $maxlen characters:\n";
+	foreach my $dir (sort keys %notuniq){
+	    print " directory $dir:\n";
+	    foreach my $trunc (sort keys %{$notuniq{$dir}}) {
+		print "  $shorts{$dir}{$trunc} truncate to $trunc\n";
+	    }
+	}
+    }
+}
+
 1;
 __END__
 
@@ -425,3 +467,6 @@ sub test6       { return join ":", __FILE__,__LINE__; }
 package Yet::Another::AutoSplit;
 sub testtesttesttest4_1 ($)  { "another test 4\n"; }
 sub testtesttesttest4_2 ($$) { "another duplicate test 4\n"; }
+package Yet::More::Attributes;
+sub test_a1 ($) : locked :locked { 1; }
+sub test_a2 : locked { 1; }