improved batch copy performance, fixed bug <A HREF="show_bug.cgi?id=14558">14558</A>. a=leaf.

xpinstall/packager/pkgcp.pl

@@ -20,16 +20,18 @@
 # 
 # Contributor(s): 
 # Jonathan Granrose (granrose@netscape.com)
-# 
 
-#
+
 # pkgcp.pl -
 #
 # Parse a package file and copy the specified files for a component
 # from the given source directory into the given destination directory
 # for packaging by the install builder.
 #
-#
+# Todo:
+#	- port to MacPerl
+#	- change warn()s to die()s to enforce updating package files.
+#	- change var names to standard form
 
 # load modules
 use Cwd;
@@ -46,14 +48,14 @@ $component        = "";		# current component being copied
 $PD               = "";		# file Path Delimiter ( /, \, or :)
 $altdest          = "";		# alternate file destination
 $line             = "";		# line being processed
-$srcdir           = "";		# directory being copied from
+$srcdir           = "";		# root directory being copied from
-$destdir          = "";		# destination being copied to
+$destdir          = "";		# root directory being copied to
 $package          = "";		# file listing files to copy
 $os               = "";  	# os type (MacOS, MSDOS, Unix)
 $verbose          = 0;		# shorthand for --debug 1
 $lineno           = 0;		# line # of package file for error text
 $debug            = 0;		# controls amount of debug output
-$batch            = 0;		# flag: are we in batch copy mode?
+$dirflag          = 0;		# flag: are we copying a directory?
 $help             = 0;		# flag: if set, print usage
 
 
@@ -122,11 +124,19 @@ LINE: while (<MANIFEST>) {
 	( $component eq "" ) &&
 		die "Error: item $_ outside a component ($package, $lineno).  Exiting...\n";
 
+	if ($line eq "") {
+		$line = $_;				# if $line not set, set it.
+	}
+
+	if ($os ne "MSDOS") {		# hack - need to fix for dos
+		$line =~ s/^$PD//;		# strip any leading path delimiter
+	}
+
 	# delete the file or directory following the '-'
 	/^-/	&& do {
-			s/^-//;		# strip leading '-'
+			$line =~ s/^-//;		# strip leading '-'
-			($debug >= 10) && print "delete: $destdir$PD$component$PD$_\n";
+			($debug >= 10) && print "delete: $destdir$PD$component$PD$line\n";
-			do_delete ("$destdir$PD$component$PD$_");
+			do_delete ("$destdir", "$component", "$line");
 			next LINE;
 	};
 
@@ -134,20 +144,16 @@ LINE: while (<MANIFEST>) {
 	/\,/	&& do {
 			/.*\,.*\,.*/ &&
 				die "Error: multiple commas not allowed ($package, $lineno): $_.\n";
-			($line, $altdest) = split (/\s*\,\s*/, $_, 2);
+			($line, $altdest) = split (/\s*\,\s*/, $line, 2);
-			$line =~ s/$PD*$//;	# strip any trailing delimiter
+			$line =~ s/$PD*$//;	# strip any trailing path delimiters
 			$altdest =~ s/$PD*$//;	# strip any trailing delimiter
-			($debug >= 10) && print "relocate: $line, $altdest.\n";
+			($debug >= 10) && print "relocate: $line => $altdest.\n";
-		};
+	};
-
-	if ($line eq "") {
-		$line = $_;	# if $line not set, set it.
-	}
 
 	# if it has wildcards, do recursive copy.
 	/(?:\*|\?)/	&& do {
 		($debug >= 10) && print "wildcard copy.\n";
-		do_batchcopy ("$srcdir$PD$line");
+		do_wildcard ("$srcdir$PD$line");
 		next LINE;
 	};
 
@@ -161,13 +167,13 @@ LINE: while (<MANIFEST>) {
 	# if it's a directory, do recursive copy.
  	(-d "$srcdir$PD$line") && do {
 		($debug >= 10) && print "directory copy.\n";
-		do_batchcopy ("$srcdir$PD$line");
+		do_copydir ("$srcdir$PD$line");
 		next LINE;
 	};
 
 	# if we hit this, it's either a file in the package file that is
 	# not in the src directory, or it is not a valid entry.
-	warn "Warning: package error or possible missing file: $_ ($package, $lineno).\n";
+	warn "Warning: package error or possible missing file: $line ($package, $lineno).\n";
 
 } # LINE
 
@@ -182,24 +188,24 @@ exit (0);
 #
 sub do_delete
 {
-	local ($target) = $_[0];
+	my ($targetpath) = $_[0];
+	my ($targetcomp) = $_[1];
+	my ($targetfile) = $_[2];
+	my ($target)     = "$targetpath$PD$targetcomp$PD$targetfile";
 
 	($debug >= 2) && print "do_delete():\n";
+	($debug >= 1) && print "-$targetfile\n";
 
-	if (-f $target) {
+	if ( -f $target ) {
-		!(-w $target) &&
+		(! -w $target ) &&
 			die "Error: delete failed: $target not writeable ($package, $component, $lineno).  Exiting...\n";
-		if ($debug >= 1) {
+		($debug >= 4) && print " unlink($target)\n";
-			print "-$target (file)\n";
-		}
 		unlink ($target) ||
 			die "Error: unlink() failed: $!.  Exiting...\n";
-	} elsif (-d $target) {
+	} elsif ( -d $target ) {
-		!(-w $target) &&
+		(! -w $target ) &&
 			die "Error: delete failed: $target not writeable ($package, $component, $lineno).  Exiting...\n";
-		if ($debug >= 1) {
+		($debug >= 4) && print " rmtree($target)\n";
-			print "-$target (directory)\n";
-		}
 		rmtree ($target, 0, 0) ||
 			die "Error: rmtree() failed: $!.  Exiting...\n";
 	} else {
@@ -210,124 +216,180 @@ sub do_delete
 
 #
 # Copy an individual file from the srcdir to the destdir.
+#
 # This is called by both the individual and batch/recursive copy routines,
-# using $batch to check if called from do_batchcopy.
+# using $dirflag to check if called from do_copydir.  Batch copy can pass in
-# 
+# directories, so be sure to check first and break if it isn't a file.
+#
 sub do_copyfile
 {
-	local ($path)  = "";
+	my ($destpath)     = "";  # destination directory path
-	my ($srcfile) = "";
+	my ($destname)     = "";  # destination file name
+	my ($destsuffix)   = "";  # destination file name suffix
+	my ($altpath)      = "";  # alternate destination directory path
+	my ($altname)      = "";  # alternate destination file name
+	my ($altsuffix)    = "";  # alternate destination file name suffix
+	my ($srcpath)      = "";  # source file directory path
+	my ($srcname)      = "";  # source file name
+	my ($srcsuffix)    = "";  # source file name suffix
 	
 	($debug >= 2) && print "do_copyfile():\n";
 
-	# set srcfile correctly depending on how called
+	# set srcname correctly depending on how called
-	if ($batch) {
+	if ( $dirflag ) {
-		$srcfile = $File::Find::name;
+		($srcname, $srcpath, $srcsuffix) = fileparse("$File::Find::name", '\..*?$');
 	} else {
-		$srcfile = "$srcdir$PD$line";
+		($srcname, $srcpath, $srcsuffix) = fileparse("$srcdir$PD$line", '\..*?$');
+	}
+
+	($debug >= 4) && print " fileparse(src): $srcpath $srcname $srcsuffix\n";
+
+	# return if srcname is a directory from do_copydir
+	if ( -d "$srcpath$srcname$srcsuffix" ) {
+		($debug >= 10) && print " return: $srcpath$srcname$srcsuffix is a directory\n";
+		return;
 	}
-	# check that source file is readable
-	(!( -r $srcfile )) &&
-		die "Error: file $srcfile is not readable ($package, $component, $lineno).\n";
 
 	# set the destination path, if alternate destination given, use it.
-	if ($altdest ne "") {
+	if ( $altdest ne "" ) {
-		if ($batch) {
+		if ( $dirflag ) {	# directory copy to altdest
-			$path = "$destdir$PD$component$PD$altdest$PD$File::Find::dir";
+			($destname, $destpath, $destsuffix) = fileparse("$destdir$PD$component$PD$altdest$PD$File::Find::name", '\..*?$');
-			$path =~ s/$srcdir$PD$line$PD//;	# rm info added by find
+			# Todo: add MSDOS hack
-			$basefile = basename ($File::Find::name);
+			$destpath =~ s/$srcdir$PD$line$PD//;	# rm info added by find
 			($debug >= 5) &&
-				print "recursive find w/altdest: $path $basefile\n";
+				print " dir copy to altdest: $destpath $destname $destsuffix\n";
-		} else {
+		} else {	# single file copy to altdest
-			$path = dirname ("$destdir$PD$component$PD$altdest");
+			($destname, $destpath, $destsuffix) = fileparse("$destdir$PD$component$PD$altdest", '\..*?$');
-			$basefile = basename ($altdest);
 			($debug >= 5) &&
-				print "recursive find w/altdest: $path $basefile\n";
+				print " file copy to altdest: $destpath $destname $destsuffix\n";
 		}
 	} else {
-		if ($batch) {
+		if ( $dirflag ) {	# directory copy, no altdest
-			$path = "$destdir$PD$component$PD$File::Find::dir";
+			($destname, $destpath, $destsuffix) = fileparse("$destdir$PD$component$PD$File::Find::name", '\..*?$');
 
 			# avert your eyes now, butt-ugly hack
-			if ($os eq "MSDOS") {
+			if ( $os eq "MSDOS" ) {
-				$path =~ s/\\/\//g;
+				$destpath =~ s/\\/\//g;
 				$srcdir =~ s/\\/\//g;
 				$PD = "/";
-				$path =~ s/$srcdir$PD//g;
+				$destpath =~ s/$srcdir$PD//g;
-				$path =~ s/\//\\/g;
+				$destpath =~ s/\//\\/g;
 				$srcdir =~ s/\//\\/g;
 				$PD = "\\";
 			} else {
-				$path =~ s/$srcdir$PD//;
+				$destpath =~ s/$srcdir$PD//;
 			}
 			# end stupid MSDOS hack
 
-			$basefile = basename ($File::Find::name);
 			($debug >= 5) &&
-				print "recursive find w/o altdest: $path $basefile\n";
+				print " dir copy w/o altdest: $destpath $destname $destsuffix\n";
-		} else {
+		} else {	# single file copy, no altdest
-			$path = dirname ("$destdir$PD$component$PD$line");
+			($destname, $destpath, $destsuffix) = fileparse("$destdir$PD$component$PD$line", '\..*?$');
-			$basefile = basename ($line);
 			($debug >= 5) &&
-				print "recursive find w/o altdest: $path $basefile\n";
+				print " file copy w/o altdest: $destpath $destname $destsuffix\n";
 		}
 	}
 
-	# create the directory path to the file if not there yet
+	# create the destination path if it doesn't exist
-	if (!( -d $path)) {
+	if (! -d "$destpath" ) {
-		mkpath ($path, 0, 0755) ||
+		($debug >= 5) && print " mkpath($destpath)\n";
+		mkpath ($destpath, 0, 0755) ||
 			die "Error: mkpath() failed: $!.  Exiting...\n";
 	}
 
-	if (-f $srcfile) {	# don't copy if it's a directory
+	# path exists, source and destination known, time to copy
-		if ($debug >= 1) {
+	if ((-f "$srcpath$srcname$srcsuffix") && (-r "$srcpath$srcname$srcsuffix")) {
-			if ($batch) {
+		if ( $debug >= 1 ) {
-				print "$basefile\n";	# from unglob
+			if ( $dirflag ) {
+				print "$destname$destsuffix\n";	# from unglob
 			} else {
-				print "$line\n";	# from single file
+				print "$line\n";		# from single file
 			}
-			if ($debug >= 3) {
+			if ( $debug >= 3 ) {
-				print "copy\t$srcfile =>\n\t\t$path$PD$basefile\n";
+				print " copy\t$srcpath$srcname$srcsuffix =>\n\t\t$destpath$destname$destsuffix\n";
 			}
 		}
-		copy ("$srcfile", "$path$PD$basefile") ||
+		copy ("$srcpath$srcname$srcsuffix", "$destpath$destname$destsuffix") ||
-			die "Error: copy of file $srcdir$PD$line failed ($package, $component, $lineno): $!.  Exiting...\n";
+			die "Error: copy of file $srcpath$srcname$srcsuffix failed ($package, $component, $lineno): $!.  Exiting...\n";
 
 		# if this is unix, set the dest file permissions
-		if ($os eq "") {
+		if ( $os eq "Unix" ) {
 			# read permissions
-			$st = stat($srcfile) ||
+			$st = stat("$srcpath$srcname$srcsuffix") ||
-				die "Error: can't stat $srcfile: $!  Exiting...\n";
+				die "Error: can't stat $srcpath$srcname$srcsuffix: $!  Exiting...\n";
 			# set permissions
-			($debug >= 2) && print "chmod ".$st->mode."\n";
+			($debug >= 2) && print " chmod ".$st->mode." $destpath$destname$destsuffix\n";
-			chmod ($st->mode, "$path$PD$basefile");
+			chmod ($st->mode, "$destpath$destname$destsuffix") ||
+				warn "Warning: chmod of $destpath$destname$destsuffix failed: $!.  Exiting...\n";
 		}
+	} else {
+		die "Error: file $srcpath$srcname$srcsuffix is not a file or is not readable ($package, $component, $lineno).\n";
 	}
 }
 
 
 #
-# Expand any wildcards, and recursively copy files and directories specified.
+# Expand any wildcards and copy files and/or directories
 #
-sub do_batchcopy
+# todo: pass individual files to do_copyfile, not do_copydir
+#
+sub do_wildcard
 {
 	my ($entry) = $_[0];
-	my (@list) = ();
+	my (@list)  = ();
+	my ($item)  = "";
 
-	($debug >= 2) && print "do_batchcopy():\n";
+	($debug >= 2) && print "do_wildcard():\n";
 
-	if ($entry =~ /(?:\*|\?)/) {		# it's a wildcard,
+	if ( $entry =~ /(?:\*|\?)/ ) {		# it's a wildcard,
-		@list = glob($entry);		# expand it, and
+		@list = glob($entry);			# expand it
-		foreach $entry (@list) {
+		($debug >= 4) && print " glob: $entry => @list\n";
-			do_batchcopy($entry);	# recursively copy results.
+
+		foreach $item ( @list ) {			# now copy each item in list
+			if ( -f $item ) {
+				($debug >= 10) && print " do_copyfile: $item\n";
+
+				# glob adds full path to item like find() in copydir so
+				# take advantage of existing code in copyfile by using
+				# $dirflag and $File::Find::name.
+
+				$File::Find::name = $item;
+				$dirflag = 1;
+				do_copyfile();
+				$dirflag = 0;
+				$File::Find::name = "";
+			} elsif ( -d $item ) {
+				($debug >= 10) && print " do_copydir($item)\n";
+				do_copydir ($item);
+			} else {
+				warn "Warning: $item is not a file or directory ($package, $component, $lineno).  Skipped...\n";
+			}
 		}
-	} else {
-		$batch = 1;			# flag for do_copyfile
-		find (\&do_copyfile, $entry);
-		$batch = 0;
 	}
 }
 
+#
+# Recursively copy directories specified.
+#
+sub do_copydir
+{
+	my ($entry) = $_[0];
+
+	$dirflag = 1;			# flag indicating directory copy in progress
+
+	($debug >= 2) && print "do_copydir():\n";
+
+	if (! -d "$entry" ) {
+		warn "Warning: $entry is not a directory ($package, $component, $lineno).  Skipped...\n";
+	}
+
+	($debug >= 4) && print " find($entry)\n";
+
+	find (\&do_copyfile, $entry);
+
+	$dirflag = 0;
+}
+
 
 #
 # Handle new component
@@ -347,7 +409,7 @@ sub do_component
 	if ( -d "$destdir$PD$component" ) {
 		warn "Warning: component directory \"$component\" already exists in \"$destdir\".\n";
 	} else {
-		($debug >= 4) && print "mkdir $destdir$PD$component\n";
+		($debug >= 4) && print " mkdir $destdir$PD$component\n";
 		mkdir ("$destdir$PD$component", 0755) ||
 			die "Error: couldn't create component directory \"$component\": $!.  Exiting...\n";
 	}
@@ -371,25 +433,32 @@ sub check_arguments
 
 	# make sure required variables are set:
 	# check source directory
-	if ($srcdir eq "") {
+	if ( $srcdir eq "" ) {
 		print "Error: source directory (--source) not specified.\n";
 		$exitval += 8;
-	} elsif (!(-d $srcdir) || !(-r $srcdir)) {
+	} elsif ((! -d $srcdir) || (! -r $srcdir)) {
 		print "Error: source directory \"$srcdir\" is not a directory or is unreadable.\n";
 		$exitval = 1;
 	}
 
 	# check destination directory
-	if ($destdir eq "") {
+	if ( $destdir eq "" ) {
 		print "Error: destination directory (--destination) not specified.\n";
 		$exitval += 8;
-	} elsif (!(-d $destdir) || !(-w $destdir)) {
+	} elsif ((! -d $destdir) || (! -w $destdir)) {
 		print "Error: destination directory \"$destdir\" is not a directory or is not writeable.\n";
 		$exitval += 2;
 	}
 
+	# check destdir not a subdir of srcdir
+	# hack - workaround for bug 14558 that should be fixed eventually.
+	if (0) {	# todo - write test
+		print "Error: destination directory must not be subdirectory of the source directory.\n";
+		$exitval += 32;
+	}
+
 	# check package file
-	if ($package eq "") {
+	if ( $package eq "" ) {
 		print "Error: package file (--file) not specified.\n";
 		$exitval += 8;
 	} elsif (!(-f $package) || !(-r $package)) {
@@ -405,19 +474,19 @@ sub check_arguments
 		$os = "MacOS";
 		$PD = ":";
 		fileparse_set_fstype ($os);
-		($debug >= 4) && print "OS: $os\n";
+		($debug >= 4) && print " OS: $os\n";
 		warn "Warning: MacOS not fully implemented/tested.\n";
 	} elsif ( $os =~ /dos/i ) {
 		$os = "MSDOS";
 		$PD = "\\";
 		fileparse_set_fstype ($os);
-		($debug >= 4) && print "OS: $os\n";
+		($debug >= 4) && print " OS: $os\n";
 		warn "Warning: MSDOS not fully implemented/tested.\n";
 	} elsif ( $os =~ /unix/i ) {
 		$os = "Unix";       # can be anything but MacOS, MSDOS, or VMS
 		$PD = "/";
 		fileparse_set_fstype ($os);
-		($debug >= 4) && print "OS: Unix\n";
+		($debug >= 4) && print " OS: Unix\n";
 	} else {
 		print "Error: OS type \"$os\" unknown.\n";
 		$exitval += 16;
@@ -464,10 +533,12 @@ Options:
 		Specifies the directory in which to create the component
 		directories and copy the files specified in the file passed
 		via --file.
-		NOTE:	This MUST be an absolute path, relative paths
-			will not work!
 		Required.
 
+NOTE:	Source and destination directories must be absolute paths.
+	Relative paths will NOT work.  Also, the destination directory
+	must NOT be a subdirectory of the source directory.
+
 	-f, --file <package file>
 		Specifies the file listing the components to be created in
 		the destination directory and the files to copy from the