kay's perl branch

src/tools/Makefile.Host

@@ -5,57 +5,18 @@ TOP = ../../..
 include $(TOP)/config/CONFIG_BASE
 
 #	install these scripts:
-SCRIPTS := installEpics getrel makeBaseApp
+#
+#	WIN32 also uses rm.pl, cp.pl, mkdir.pl, rmdir.pl
+#	byt they are called from here, not installed
+SCRIPTS       := installEpics.pl makeBaseApp.pl
 
-#	But: before anything is done, installEpics has to be in place
+#	Before anything is done, installEpics has to be in place.
 #	The first action in a full build & install is 'make inc.host',
 #	that's where we hook into:
-inc:: $(INSTALL_BIN)/installEpics
+inc:: $(INSTALL_BIN)/installEpics.pl
 
-
-#	This Makefile.Host is ugly
-#	because the install process (chmod ...)
-#	is different for WIN32.
-#
-#	This is usually hidden in installEpics,
-#	but we are about to install installEpics...
-#
-#	The same applies to the 'os' directory:
-#	If we are on e.g. WIN32 and have os/WIN32/stuff,
-#	that whould have precedence over ./stuff.
-#	But again: we are just installing the Makesystem here.
-#
-#	-kuk-
-
-ifdef WIN32
-
-$(INSTALL_BIN)/installEpics: ../os/WIN32/installEpics
-	@echo "Installing $@ for WIN32"
-	@../os/WIN32/testmkdir $(INSTALL_LOCATION_BIN)
-	@../os/WIN32/testmkdir $(INSTALL_BIN)
-	@../os/WIN32/installEpics ../os/WIN32/testmkdir    $(INSTALL_BIN)
-	@../os/WIN32/installEpics ../os/WIN32/installEpics $(INSTALL_BIN)
-else
-
-$(INSTALL_BIN)/installEpics: testmkdir installEpics 
-	@echo "Installing $@"
-	@./testmkdir $(INSTALL_LOCATION_BIN)
-	@./testmkdir $(INSTALL_BIN)
-	@./installEpics -m 555 testmkdir $(INSTALL_BIN)
-	@./installEpics -m 555 installEpics $(INSTALL_BIN)
-
-#	make sure the scripts are executable:
-testmkdir: ../testmkdir
-	@$(RM) $@
-	@$(CP) $< $@
-	@$(CHMOD) 755 $@
-
-installEpics: ../installEpics
-	@$(RM) $@
-	@$(CP) $< $@
-	@$(CHMOD) 755 $@
-
-endif
+$(INSTALL_BIN)/installEpics.pl: ../installEpics.pl
+	$(PERL) ../installEpics.pl -d -m 555 ../installEpics.pl $(INSTALL_BIN)
 
 include $(TOP)/config/RULES.Host
 

src/tools/cp.pl

@@ -0,0 +1,39 @@
+#!/usr/local/bin/perl
+#
+#	UNIX-cp in Perl
+
+use File::Copy;
+
+sub Usage
+{
+	my ($txt) = @_;
+
+	print "Usage:\n";
+	print "\tcp file1 file2\n";
+	print "\tcp file [ file2 file3 ...] directory\n";
+	print "\nError: $txt\n" if $txt;
+
+	exit 2;
+}
+
+# need at least two args: ARGV[0] and ARGV[1]
+Usage("need more args") if $#ARGV < 1;
+
+$target=$ARGV[$#ARGV];
+@sources=@ARGV[0..$#ARGV-1];
+
+if (-d $target)
+{
+	foreach $file ( @sources )
+	{
+		copy ($file, "$target/$file");
+	}
+}
+else
+{
+	Usage("Cannot copy more than one source into a single target")
+		if ($#sources != 0);
+	copy ($sources[0], $target);
+}
+
+# EOF cp.pl

src/tools/installEpics.pl

@@ -0,0 +1,108 @@
+#!/usr/local/bin/perl
+#
+#	InstallEpics.pl
+#
+#	InstallEpics is used within makefiles to copy new versions of
+#	files into a destination directory.
+#	Based on installEpics shell script.
+#
+#	2-4-97 -kuk-
+#
+##########################################################
+
+use Getopt::Std;
+use File::Path;
+use File::Copy;
+
+$tool=$0;
+$tool=~ s'.*[/\\].+'';	# basename
+$mode=0755;
+
+# get command line options
+getopt "m";
+$mode = oct ($opt_m) if ($opt_m);
+
+#	Complain about obsolete options:
+Usage("unknown option given") if ($opt_g or $opt_o or $opt_c or $opt_s);
+
+$num_files = $#ARGV;
+# at least two args required
+Usage ("Nothing to install") if ($num_files < 1);
+
+#	split args in file1 ... fileN target_dir:
+@files=@ARGV[0..$num_files-1];
+$install_dir=$ARGV[$num_files];
+$install_dir =~ s[\\][/]g;	# maybe fix DOS-style path
+$install_dir =~ s[/$][];	# remove trailing '/'
+
+#	Do we have to create the directory?
+unless (-d $install_dir)
+{
+	#	Create dir only if -d option given
+	Usage ("$install_dir does not exist") unless ($opt_d);
+
+	#	Create all the subdirs that lead to $install_dir
+	mkpath ($install_dir, 1, 0777);
+}
+
+foreach $source ( @files )
+{
+	Usage ("Can't find file '$source'") unless -f $source;
+
+	$basename=$source;
+	$basename=~s'.*[/\\]'';
+	$target  = "$install_dir/$basename";
+
+	#	The Win32 filesystem seems to be 'slow',
+	#	i.e. $target may look like 'up to date'
+	#	unless you wait an hour.
+	#	-> skip this test on WIN32 ?
+	#if (-f $target  and  $^O ne "MSWin32")
+	if (-f $target)
+	{
+		if (-M $target  <  -M $source    and
+		    -C $target  <  -C $source)
+		{
+			print "$target is up to date\n";
+			next;
+		}
+		else
+		{
+			#	remove old target, make sure it is deletable:
+			chmod 0777, $target;
+			unlink $target;
+		}
+	}
+
+	# print "Installing $source into $install_dir\n";
+	copy ($source, $target) or die "Copy failed";
+
+	#	chmod 0555 <read-only> DOES work on WIN32, but:
+	#	Another chmod 0777 to make it write- and deletable
+	#	will then fail.
+	#	-> you have to use Win32::SetFileAttributes
+	#	   to get rid of those files from within Perl.
+	#	Because the chmod is not really needed on WIN32,
+	#	just skip it!
+	chmod $mode, $target unless ($^O eq "MSWin32");
+}
+
+sub Usage
+{
+	my ($txt) = @_;
+
+	print "Usage:\n";
+	print "\t$tool [ -m mode ] file ... directory\n";
+	print "\n";
+	print "\t-d             Create non-exising directories\n";
+	print "\t-m mode        Set the mode for the installed file";
+		print " (0755 by default)\n";
+	print "\tfile           Name of file\n";
+	print "\tdirectory      Destination directory\n";
+
+	print "$txt\n" if $txt;
+
+	exit 2;
+}
+
+#	EOF installEpics.pl

src/tools/mkdir.pl

@@ -0,0 +1,23 @@
+#!/usr/local/bin/perl
+#
+#	UNIX-mkdir in Perl
+#
+#	-p option generates full path to given dir
+
+use File::Path;
+use Getopt::Std;
+getopt();
+
+foreach $dir ( @ARGV )
+{
+	if ($opt_p)
+	{
+		mkpath ($dir) or die "Cannot make directory $dir";
+	}
+	else
+	{
+		mkdir ($dir, 0777) or die "Cannot make directory $dir";
+	}
+}
+
+# EOF mkdir.pl

src/tools/mv.pl

@@ -0,0 +1,69 @@
+#!/usr/local/bin/perl
+#
+#	UNIX-mv in Perl
+
+use File::Copy;
+
+sub Usage
+{
+	my ($txt) = @_;
+
+	print "Usage:\n";
+	print "\tmv oldname newname\n";
+	print "\tmv file [ file2 file3 ...] directory\n";
+	print "\nError: $txt\n" if $txt;
+
+	exit 2;
+}
+
+sub Move
+{
+	my ($src, $dest) = @_;
+
+	print "Move($src, $dest)\n";
+
+	copy ($src, $dest) or die "Cannot copy $src to $dest";
+	unlink ($src) or die "Cannot remove $src";
+}
+
+#	return filename.ext from  Drive:/path/a/b/c/filename.ext
+sub Filename
+{
+	my ($file) = @_;
+
+	$file =~ s'.*[/\\]'';
+
+	return $file;
+}
+
+# need at least two args: ARGV[0] and ARGV[1]
+Usage("need more args") if $#ARGV < 1;
+
+$target=$ARGV[$#ARGV];
+@sources=@ARGV[0..$#ARGV-1];
+
+print "move @sources into $target\n";
+
+#	If target is (already existent) directory,
+#	move files into it:
+if (-d $target)
+{
+	foreach $file ( @sources )
+	{
+		Move ($file, "$target/" . Filename($file));
+	}
+	exit 0;
+}
+
+#	Otherwise the target is a filename.
+#	Now 'mv' may be either a 'move' or a 'rename',
+#	in any case it requires exactly two args: old and new name.
+
+Usage("Need exactly one source") if $#sources != 0;
+$source = @sources[0];
+
+#	Move only if a simple rename 
+#	fails (e.g. across file systems):
+Move ($source, $target) unless (rename $source, $target);
+
+# EOF mv.pl

src/tools/rm.pl

@@ -0,0 +1,32 @@
+#!/usr/local/bin/perl
+#
+#	UNIX-rm in Perl
+
+use File::Path;
+use File::Find;
+use Getopt::Std;
+
+getopt();
+
+foreach $arg ( @ARGV )
+{
+	next unless -e $arg;
+
+	if (-d $arg)
+	{
+		if ($opt_r and $opt_f)
+		{
+			rmtree $arg;
+		}
+		else
+		{
+			rmdir ($arg) or die "Cannot delete $arg";
+		}
+	}
+	else
+	{
+		unlink ($arg) or die "Cannot delete $arg";
+	}
+}
+
+# EOF rm.pl