From: meissner@osf.org (Michael Meissner)
Newsgroups: comp.lang.perl
Subject: Re: copy() primitive?
Date: 21 Dec 92 02:25:49 GMT
Organization: Open Software Foundation

In article <1gqkqtINN8ne@perv.hal.COM> aahz@hal.COM (Tom Wylie) writes:

| Is there some reason there isn't a primitive for copying files?
| (along the lines of unlink and rename).  firing off backticked /bin/cp's
| seems amazingly inefficient, and while yes I could use filehandles, it
| seems to me that a primitive that just horks in the file and spits it
| out somewhere else would be much faster.  I can't imagine that this
| hasn't come up, so I figure there must be a good reason why there isn't
| a copy() primitive, just wondering what it is.

Here is my general toolbox, that includes a &copy_file function (look
in mrm-files.pl).  I included the other files for doing
columinization, execution, etc.

#!/bin/sh
# This is a shell archive (produced by shar 3.49)
# To extract the files from this archive, save it to a file, remove
# everything above the "!/bin/sh" line above, and type "sh file_name".
#
# made 12/21/1992 02:23 UTC by meissner@curley
# Source directory /usr/users/meissner/bin.perl
#
# existing files will NOT be overwritten unless -c is specified
#
# This shar contains:
# length  mode       name
# ------ ---------- ------------------------------------------
#   2344 -rw-rw-r-- mrm-columnize.pl
#  13606 -rw-r--r-- mrm-execute.pl
#   9717 -rw-rw-r-- mrm-files.pl
#   1026 -rw-r--r-- mrm-eval.pl
#   6078 -rw-r--r-- mrm-export.pl
#
# ============= mrm-columnize.pl ==============
if test -f 'mrm-columnize.pl' -a X"$1" != X"-c"; then
	echo 'x - skipping mrm-columnize.pl (File already exists)'
else
echo 'x - extracting mrm-columnize.pl (Text)'
sed 's/^X//' << 'SHAR_EOF' > 'mrm-columnize.pl' &&
X#! /usr/local/bin/perl
X
X{
X	package main;
X	require 'mrm-export.pl';
X
X	&export ('columnize', $EXPORT_FUNCTION, 'columnize', 'line_length');
X
X	$EXPORT_FUNCTION;	# silence perl -w
X}
X
Xpackage columnize;
X
X# Function to return a string array, such that when each element is
X# printed, it is printed as a series of columns, each equally spaced.
X#
X# Arg 1:	The number of leading spaces to print on each line.
X# Arg 2:	The number of spaces to leave between each column.
X# Arg 3:	The line width to use or 0, to use the current terminal's line size.
X# Arg 4:	The minimun column width to use
X# Arg 5-	Items to columnize.
X
Xsub columnize {
X	local ($leading_spaces)	= shift (@_);
X	local ($num_spaces)	= shift (@_);
X	local ($user_line_size)	= shift (@_);
X	local ($max_length)	= shift (@_);
X	local (@ret)		= ();
X	local ($cur_col)	= 1;
X	local ($initial)	= ("\t" x ($leading_spaces / 8)) . (' ' x ($leading_spaces % 8));
X	local ($element);
X	local ($ncols);
X
X	if ($#_ >= $[) {
X		foreach $element (@_) {
X			$max_length = length ($element)		if (length ($element) > $max_length);
X		}
X
X		$ncols = &line_length ($user_line_size) - 1 - $leading_spaces;
X		$ncols += ($num_spaces - 1)			if ($num_spaces > 0);
X		$ncols /= ($max_length + $num_spaces);
X		$ncols = 1					if ($ncols <= 0);
X
X		foreach $element (@_[ $[ .. $#_ - 1 ]) {
X			if (++$cur_col >= $ncols) {
X				$cur_col = 1;
X				push (@ret, "$initial$element\n");
X				$initial = ' ' x $leading_spaces;
X
X			} else {
X				push (@ret, ($initial . $element . (' ' x ($max_length - length ($element)))));
X				$initial = ' ' x $num_spaces;
X			}
X		}
X
X		push (@ret, "$initial$_[$#_]\n");
X	}
X
X	return @ret;
X}
X
X
X# Function to get the line length.
X
Xsub line_length {
X	local ($user_line_size)	= shift (@_);
X
X	return $user_line_size				if (defined ($user_line_size) && $user_line_size > 0);
X
X	if (! defined ($line_length) || ! $line_length) {
X
X		if (defined ($ENV{'COLUMNS'}) && $ENV{'COLUMNS'} > 0) {
X			$line_length = $ENV{'COLUMNS'} + 0;
X
X		} else {
X			local ($winsize)	= "\0\0\0\0\0\0\0\0";
X			local ($TIOCGWINSZ)	= 0x40087468;		# on OSF/1 at least
X			local (@winsize2);
X
X			$line_length = 79;
X			if (-t STDIN && ioctl (STDIN, $TIOCGWINSZ, $winsize)) {
X				@winsize2 = unpack ('SSSS', $winsize);
X
X				$line_length = $winsize2[1]	if ($winsize2[1] > 0);
X			}
X		}
X	}
X
X	return $line_length;
X}
X
X
X# Return 1, so require succeeds.
X
X1;
SHAR_EOF
chmod 0664 mrm-columnize.pl ||
echo 'restore of mrm-columnize.pl failed'
Wc_c="`wc -c < 'mrm-columnize.pl'`"
test 2344 -eq "$Wc_c" ||
	echo 'mrm-columnize.pl: original size 2344, current size' "$Wc_c"
fi
# ============= mrm-execute.pl ==============
if test -f 'mrm-execute.pl' -a X"$1" != X"-c"; then
	echo 'x - skipping mrm-execute.pl (File already exists)'
else
echo 'x - extracting mrm-execute.pl (Text)'
sed 's/^X//' << 'SHAR_EOF' > 'mrm-execute.pl' &&
X#! /usr/local/bin/perl
X
X# Wrappers around execute, providing control on whether to die or not,
X# and to handle redirection.
X
X{
X	package main;
X	require 'mrm-export.pl';
X
X	&export ('execute', $EXPORT_FUNCTION,
X		 'execute_status',
X		 'execute',
X		 'execute_or_die',
X		 'execute_pipe',
X		 'execute_pipe_or_die',
X		 'execute_redirect',
X		 'execute_redirect_or_die',
X		 'execute_output',
X		 'execute_output_or_die',
X		 'spawn',
X		 'spawn_redirect',
X		 'spawn_wait',
X		 'execute_trace',
X		 'execute_run',
X		 'change_directory');
X
X	&import ('execute', $IMPORT_FUNCTION, 'trace', 'trace_enable', 'fix_file', 'unfix_file');
X	&import ('execute', $IMPORT_VARIABLE, 'trace_p');
X
X	$EXPORT_FUNCTION || $IMPORT_FUNCTION || $IMPORT_VARIABLE;	# silence perl -w
X}
X
Xpackage execute;
X
X{
X	$prog		= substr ($0, rindex ($0, '/') + 1);
X	$exec		= !defined ($ENV{'EXECUTE_NOEXEC'});
X	$no_stdin	= undef;
X	$no_stdout	= undef;
X	$no_stderr	= undef;
X	$no_func	= undef;
X	$no_parent_func	= undef;
X	$no_child_func	= undef;
X	$do_wait	= 1;
X	$no_wait	= 0;
X	@sig_names	= ('SIG<none>',
X			   'SIGHUP',
X			   'SIGINT',
X			   'SIGQUIT',
X			   'SIGILL',
X			   'SIGTRAP',
X			   'SIGABRT',
X			   'SIGEMT',
X			   'SIGFPE',
X			   'SIGKILL',
X			   'SIGBUS',
X			   'SIGSEGV',
X			   'SIGSYS',
X			   'SIGPIPE',
X			   'SIGALRM',
X			   'SIGTERM',
X			   'SIGURG',
X			   'SIGSTOP',
X			   'SIGTSTP',
X			   'SIGCONT',
X			   'SIGCHLD',
X			   'SIGTTIN',
X			   'SIGTTOU',
X			   'SIGIO',
X			   'SIGXCPU',
X			   'SIGXFSZ',
X			   'SIGVTALRM',
X			   'SIGPROF',
X			   'SIGWINCH',
X			   'SIGINFO',
X			   'SIGUSR1',
X			   'SIGUSR2');
X}
X
X
X# Function to decode the exit status into a normal readable string.
X
Xsub execute_status {
X	local ($status)		= undef;
X	local ($raw_status)	= (scalar (@_) > 0) ? shift (@_) : $?;
X
X	if ($raw_status == 0) {
X		$status = 'no errors';
X
X	} elsif ($raw_status >= 256) {				# non-zero exit
X		local ($ret_code) = $raw_status >> 8;
X		$status = "exit status = $ret_code";
X			
X	} elsif ($raw_status > 0) {				# killed by signal
X		local ($sig)  = $raw_status & 127;
X		local ($name) = $sig_names[ $sig - $[ ];
X		local ($core) = ($raw_status & 128) ? ', core dumped' : '';
X		$status = "Killed by signal $sig ($name)$core";
X	}
X
X	if (wantarray) {
X		($status, $raw_status);
X	} else {
X		$status;
X	}
X}
X
X
X# Internal function to execute a program.
X# Arg 1 is the file to open as stdin,  or undef
X# Arg 2 is the file to open as stdout, or undef
X# Arg 3 is the file to open as stderr, or undef
X# Arg 4 is the function to call with each line of input when spawning the program on a pipe
X# Arg 5 is the function to call in the parent context after starting child.
X# Arg 6 is the function to call in the child context before doing the exec.
X# Arg 7 is true if we want to wait for the process to finish.
X# Arg 8 is the program to execute.
X# Arg 9.. are the program arguments.
X
X# If we are waiting for the process to finish, the return value is the exit status
X# If we are not waiting, the return value is the child pid
X
Xsub execute_internal {
X	local ($in)			= shift (@_);
X	local ($out)			= shift (@_);
X	local ($err)			= shift (@_);
X	local ($pipe_func)		= shift (@_);
X	local ($parent_func)		= shift (@_);
X	local ($child_func)		= shift (@_);
X	local ($wait)			= shift (@_);
X	local ($child_program)		= shift (@_);
X	local ($pid)			= undef;
X	local ($status)			= undef;
X	local ($")			= ' ';
X	local (@trace_args)		= @_;
X
X	$? = 0;
X	push (@trace_args, $in)						if (defined ($in));
X	push (@trace_args, $out)					if (defined ($out));
X	push (@trace_args, "2$err")					if (defined ($err));
X	&trace ('exec', $child_program, @trace_args)			if ($trace_p);
X
X	if (!$exec) {
X		$status = 'no exec';
X		&trace ('stop', "$child_program:", $status)		if ($trace_p);
X		return ($status, 0);
X	}
X
X	(! defined ($pipe_func)) || pipe (PIPE_READ, PIPE_WRITE)	|| return ("error in pipe: $!", -1);
X	
X	$pid = fork ();	       
X	(defined ($pid) && $pid != -1)					|| return ("fork problems: $!", -1);
X	
X	if ($pid == 0) {		# child context	       
X	
X		if (defined ($pipe_func)) {	      
X			open (STDOUT, ">&PIPE_WRITE")			|| die "$prog: dup stdout: $!\n";
X			open (STDERR, '>&STDOUT')			|| die "$prog: dup stderr: $!\n";
X			close (PIPE_READ)				|| die "$prog: close pipe reader: $!\n";
X			close (PIPE_WRITE)				|| die "$prog: close pipe writer: $!\n";
X		}	 
X	
X		(!defined ($in))  || open (STDIN,  $in)			|| die "$prog: open $in: $!\n";
X		(!defined ($out)) || open (STDOUT, $out)		|| die "$prog: open $out: $!\n";
X		(!defined ($err)) || open (STDERR, $err)		|| die "$prog: open $err: $!\n";
X
X		&$child_func ($child_program, @_)			if (defined ($child_func));
X
X		exec ($child_program, @_);
X		die "$prog: $child_program: $!\n";
X
X	} else {			# parent context
X		if (!$wait) {
X			&$parent_func ($pid, $child_program, @_)	if (defined ($parent_func));
X			return $pid;
X		}
X
X		local ($int, $quit) = ($SIG{'INT'}, $SIG{'QUIT'});
X		$int  = 'DEFAULT'					if (!defined ($int));
X		$quit = 'DEFAULT'					if (!defined ($quit));
X		$SIG{'INT'}  = 'IGNORE'					if ($int  eq 'DEFAULT');
X		$SIG{'QUIT'} = 'IGNORE'					if ($quit eq 'DEFAULT');
X
X		&$parent_func ($pid, $child_program, @_)		if (defined ($parent_func));
X
X		if (defined ($pipe_func)) {
X			close (PIPE_WRITE)				|| return ("close pipe writer: $!", -1);
X			while (<PIPE_READ>) {
X				chop;
X				&trace ('pipe', $_)			if ($trace_p);
X				&$pipe_func ($_);
X			}
X			close (PIPE_READ)				|| return ("close pipe reader: $!", -1);
X		}
X
X		waitpid ($pid, 0);
X
X		$SIG{'INT'}  = $int;
X		$SIG{'QUIT'} = $quit;
X	}
X
X	$status = &execute_status ($?);
X	&trace ('stop', "$child_program:", $status)			if ($trace_p);
X	($status, $?);
X}
X
X
X# Function to execute a program, die on signals SIGINT, SIGHUP
X
Xsub execute {
X	local ($") = ' ';
X	local ($status, $raw_status) = &execute_internal ($no_stdin,
X							  $no_stdout,
X							  $no_stderr,
X							  $no_func,
X							  $no_parent_func,
X							  $no_child_func,
X							  $do_wait,
X							  @_);
X
X	die "$prog: @_: $status\n"				if ($raw_status == -1
X								    || ($raw_status & 127) == 2
X								    || ($raw_status & 127) == 3);
X
X	if (wantarray) {
X		($status, $raw_status);
X	} else {
X		$status;
X	}
X}
X
X
X# Function to execute a program, and die if there were errors
X
Xsub execute_or_die {
X	local ($") = ' ';
X	local ($status, $raw_status) = &execute_internal ($no_stdin,
X							  $no_stdout,
X							  $no_stderr,
X							  $no_func,
X							  $no_parent_func,
X							  $no_child_func,
X							  $do_wait,
X							  @_);
X
X	die "$prog: @_: $status\n"				if ($raw_status != 0);
X
X	if (wantarray) {
X		($status, $raw_status);
X	} else {
X		$status;
X	}
X}
X
X
X# Function to execute a program, and direct it's stdout/stderr to a pipe, and call a function
X# with each line of the pipe.  The first argument is the name of the function
X
Xsub execute_pipe {
X	local ($func)			= shift (@_);
X	local ($")			= ' ';
X	local ($package, $src, $line)	= caller;
X
X	$func =~ s/^/$package'/					if ($func !~ /'/);
X	local ($status, $raw_status) = &execute_internal ($no_stdin,
X							  $no_stdout,
X							  $no_stderr,
X							  $func,
X							  $no_parent_func,
X							  $no_child_func,
X							  $do_wait,
X							  @_);
X
X	die "$prog: @_: $status\n"				if ($raw_status == -1
X								    || ($raw_status & 127) == 2
X								    || ($raw_status & 127) == 3);
X
X	if (wantarray) {
X		($status, $raw_status);
X	} else {
X		$status;
X	}
X}
X
X
X# Function to execute a program, and direct it's stdout/stderr to a pipe, and call a function
X# with each line of the pipe.  The first argument is the name of the function.  Die if the
X# program returns a non-zero status.
X
Xsub execute_pipe_or_die {
X	local ($func)			= shift (@_);
X	local ($")			= ' ';
X	local ($package, $src, $line)	= caller;
X
X	$func =~ s/^/$package'/					if ($func !~ /'/);
X	local ($status, $raw_status) = &execute_internal ($no_stdin,
X							  $no_stdout,
X							  $no_stderr,
X							  $func,
X							  $no_parent_func,
X							  $no_child_func,
X							  $do_wait,
X							  @_);
X
X	die "$prog: @_: $status\n"				if ($raw_status != 0);
X
X	if (wantarray) {
X		($status, $raw_status);
X	} else {
X		$status;
X	}
X}
X
X
X# Function to execute a program, and redirect its standard files.  The first
X# three arguments are the file names for stdin, stdout, or stderr.
X
Xsub execute_redirect {
X	local ($package,$src,$line)	= caller;
X	local ($stdin)			= &fix_file (shift (@_), '<', $package);
X	local ($stdout)			= &fix_file (shift (@_), '>', $package);
X	local ($stderr)			= &fix_file (shift (@_), '>', $package);
X	local ($")			= ' ';
X
X	local ($status, $raw_status) = &execute_internal ($stdin,
X							  $stdout,
X							  $stderr,
X							  $no_func,
X							  $no_parent_func,
X							  $no_child_func,
X							  $do_wait,
X							  @_);
X
X	die "$prog: @_: $status\n"				if ($raw_status == -1
X								    || ($raw_status & 127) == 2
X								    || ($raw_status & 127) == 3);
X
X	if (wantarray) {
X		($status, $raw_status);
X	} else {
X		$status;
X	}
X}
X
X
X# Function to execute a program, and redirect its standard files.  The first
X# three arguments are the file names for stdin, stdout, or stderr.  If the program
X# returns non-zero, die.
X
Xsub execute_redirect_or_die {
X	local ($package,$src,$line)	= caller;
X	local ($stdin)			= &fix_file (shift (@_), '<', $package);
X	local ($stdout)			= &fix_file (shift (@_), '>', $package);
X	local ($stderr)			= &fix_file (shift (@_), '>', $package);
X	local ($")			= ' ';
X
X	local ($status, $raw_status) = &execute_internal ($stdin,
X							  $stdout,
X							  $stderr,
X							  $no_func,
X							  $no_parent_func,
X							  $no_child_func,
X							  $do_wait,
X							  @_);
X
X	die "$prog: @_: $status\n"				if ($raw_status != 0);
X
X	if (wantarray) {
X		($status, $raw_status);
X	} else {
X		$status;
X	}
X}
X
X
X# Function to execute a program, and return the output (the same as `` with tracing).
X# The first argument is non-null if we want to chop off newlines.
X
Xsub execute_output {
X	local ($do_chop)	= shift (@_);
X	local ($child_program)	= $_[$[];
X	local ($status)		= undef;
X	local ($")		= ' ';
X	local ($return_string)	= undef;
X	local (@return_array)	= ();
X	local (@temp_array)	= ();
X	local ($i)		= undef;
X
X	$? = 0;
X	&trace ('exec output',
X		(($do_chop) ? '[chop]' : '[no chop]'),
X		((wantarray) ? '[wantarray]' : '[scalar]'), @_)		if ($trace_p);
X
X	if (!$exec) {
X		$status = 'no exec';
X		&trace ('stop', "$child_program:", $status)		if ($trace_p);
X		return "";
X	}
X
X	if (wantarray) {
X		@return_array = `@_`;
X		foreach $temp_string (@return_array) {
X			chop ($temp_string)				if (substr ($temp_string, -1) eq "\n");
X			&trace ('output', $temp_string)			if ($trace_p);
X		}
X
X		$status = &execute_status ($?);
X		&trace ('stop', "$child_program:", $status)		if ($trace_p);
X
X		if ($do_chop) {
X			for ($i = $[; $i <= $#return_array; $i++) {
X				chop ($return_array[$i])		if (substr ($return_array[$i], -1) eq "\n");
X			}
X		}
X
X		@return_array;
X
X	} else {
X		local ($temp_string) = undef;
X
X		$return_string = `@_`;
X		$temp_string = $return_string;
X		chop ($temp_string)					if (substr ($temp_string, -1) eq "\n");
X
X		&trace ('output', $temp_string)				if ($trace_p);
X
X		$status = &execute_status ($?);
X		&trace ('stop', "$child_program:", $status)		if ($trace_p);
X
X		chop ($return_string)					if ($do_chop
X									    && substr ($return_string, -1) eq "\n");
X
X		$return_string;
X	}
X}
X
X
X# Function to execute a program, and return the output (the same as `` with tracing).
X# The first argument is non-null if we want to chop off newlines.  If the program
X# dies, abort.
X
Xsub execute_output_or_die {
X	local ($pid)		= undef;
X	local ($return_string)	= undef;
X	local (@return_array)	= ();
X
X	if (wantarray) {
X		@return_array = &execute_output;	# pass ARGV straight through
X
X		if ($? != 0) {
X			shift (@_);			# remove do_chop
X			local ($status) = &execute_status ($?);
X			local ($") = ' ';
X			die "$prog: @_: $status\n";
X		}
X
X		@return_array;
X
X	} else {
X		$return_string = &execute_output;	# pass ARGV straight through
X
X		if ($? != 0) {
X			shift (@_);			# remove do_chop
X			local ($status) = &execute_status ($?);
X			local ($") = ' ';
X			die "$prog: @_: $status\n";
X		}
X
X		$return_string;
X	}
X}
X
X
X# Function to execute a program and not wait for it to finish
X
Xsub spawn {
X	local ($") = ' ';
X	return &execute_internal ($no_stdin,
X				  $no_stdout,
X				  $no_stderr,
X				  $no_func,
X				  $no_parent_func,
X				  $no_child_func,
X				  $no_wait,
X				  @_);
X}
X
X
X# Function to execute a program, redirect its standard files, and not
X# wait for it to finish.  The first three arguments are the file names
X# for stdin, stdout, or stderr.
X
Xsub spawn_redirect {
X	local ($package,$src,$line)	= caller;
X	local ($stdin)			= &fix_file (shift (@_), '<', $package);
X	local ($stdout)			= &fix_file (shift (@_), '>', $package);
X	local ($stderr)			= &fix_file (shift (@_), '>', $package);
X	local ($")			= ' ';
X
X	return &execute_internal ($stdin,
X				  $stdout,
X				  $stderr,
X				  $no_func,
X				  $no_parent_func,
X				  $no_child_func,
X				  $no_wait,
X				  @_);
X}
X
X
X# Wait for a spawn'ed process to die, and return it's status
X
Xsub spawn_wait {
X	local ($pid)	= (scalar (@_) > 0) ? shift (@_) : -1;
X
X	waitpid ($pid, 0);
X	return &execute_status ($?);
X}
X
X
X# Function to enable or disable execute tracing
X
Xsub execute_trace {
X	&trace_enable;			# pass args along to trace_enable
X}
X
X
X# Function to enable or disable executing the program
X
Xsub execute_run {
X	$exec = (scalar (@_) > 0) ? shift (@_) : 1;
X}
X
X
X# Function to change directory, and trace if needed.
X
Xsub change_directory {
X	local ($dir) = shift (@_);
X
X	return						if (defined ($cur_dir) && ($dir =~ m!^/!) && $dir eq $cur_dir);
X
X	&trace ('cd', $dir)				if ($trace_p);
X	chdir ($dir)					|| die "$prog: chdir $dir: $!\n";
X	$cur_dir = ($dir =~ m!^/!) ? $dir : undef;
X}
X
X
X# Make sure require doesn't abort.
X1;
SHAR_EOF
chmod 0644 mrm-execute.pl ||
echo 'restore of mrm-execute.pl failed'
Wc_c="`wc -c < 'mrm-execute.pl'`"
test 13606 -eq "$Wc_c" ||
	echo 'mrm-execute.pl: original size 13606, current size' "$Wc_c"
fi
# ============= mrm-files.pl ==============
if test -f 'mrm-files.pl' -a X"$1" != X"-c"; then
	echo 'x - skipping mrm-files.pl (File already exists)'
else
echo 'x - extracting mrm-files.pl (Text)'
sed 's/^X//' << 'SHAR_EOF' > 'mrm-files.pl' &&
X#! /usr/local/bin/perl
X
X# Subroutine library for common file related actions.
X
X{
X	package main;
X	require 'stat.pl';
X	require 'mrm-export.pl';
X
X	&export ('files', $EXPORT_FUNCTION,
X		 'rename_file',
X		 'change_mode',
X		 'make_directory',
X		 'delete_file',
X		 'copy_file',
X		 'compare_files');
X
X	&import ('files', $IMPORT_FUNCTION, 'trace', 'fix_file', 'unfix_file');
X	&import ('files', $IMPORT_VARIABLE, 'trace_p');
X
X	$EXPORT_FUNCTION || $IMPORT_FUNCTION || $IMPORT_VARIABLE;	# silence perl -w
X}
X
Xpackage files;
X$bufsize = 16384;
X$prog = substr ($0, rindex ($0, '/') + 1);
X	
X
X# Function to rename a file, trace the result, and die if an error occurred.
X
Xsub rename_file {
X	local ($nargs)		= scalar (@_);
X	die "$prog: rename_file called with $nargs arguments.\n" if ($nargs != 2);
X
X	local ($old, $new)	= @_;
X
X	&delete_file ($new)					if (-e $new);
X	&trace ('rename', $old, $new)				if ($trace_p);
X	rename ($old, $new)					|| die "$prog: rename $old $new: $!\n";
X	1;
X}
X
X
X# Function to change the mode on one or more files, and die if there was any errors
X
Xsub change_mode {
X	local ($nargs)		= scalar (@_);
X	die "$prog: change_mode called with $nargs arguments.\n" if ($nargs < 2);
X
X	local ($mode, @files)	= @_;
X	local ($mode_octal)	= sprintf ("0%03o", $mode);
X	local (@errors)		= ();
X
X	foreach (@files) {
X		&trace ('chmod', $mode_octal, $_)		if ($trace_p);
X		chmod ($mode, $_)				|| push (@errors, "$prog: chmod $mode_octal $_: $!\n");
X	}
X
X	die join ('', @errors)					if (scalar (@errors) > 0);
X	1;
X}
X
X
X# Function to make a directory, trace the result, and die if an error occurred.
X# If any parent directories also don't exist, they are made too.
X
Xsub make_directory {
X	local ($nargs)		= scalar (@_);
X	die "$prog: make_directory called with $nargs arguments.\n" if ($nargs == 0 || $nargs > 2);
X
X	local ($name)	= shift (@_);
X	local ($mode)	= (scalar (@_) > 0) ? shift (@_) : 0755;
X	local ($pmode)	= sprintf ("0%03o", $mode);
X	local (@pieces)	= split ('/', $name);
X	local ($dir)	= undef;
X	local ($i);
X
X	for ($i = $[; $i <= $#pieces; $i++) {
X		$dir = join ('/', @pieces[ $[..$i ]);
X		next						if ($dir eq '');
X
X		if (! -d $dir) {
X			&trace ("mkdir", $dir, $pmode)		if ($trace_p);
X			mkdir ($dir, $mode)			|| die "$prog: mkdir $dir $pmode: $!\n";
X		}
X	}
X
X	1;
X}
X
X
X# Function to delete one or more files.
X# If any of the of files is a directory, delete all of it's contents.
X# Return value is the number of deletes that failed.
X
Xsub delete_file {
X	local (@files)		= @_;
X	local (@dirstack)	= ();
X	local ($ret)		= 0;
X	local ($ret2);
X	local ($file);
X	local ($subfile);
X
X	while ($file = shift (@files)) {
X		if (-l $file || (-e _ && !-d _)) {
X			&trace ('unlink', $file)		if ($trace_p);
X			$ret2 = unlink ($file);
X			if (!$ret2) {
X				$ret++;
X				warn "$prog: unlink $file: $!\n";
X			}
X
X		} elsif (-d _) {
X			&change_mode (0777, $file)		if (! -w _);
X
X			&trace ('opendir', $file)		if ($trace_p);
X			opendir (DIR, $file)			|| warn "$prog: opendir $file: $!\n";
X
X			while ($subfile = readdir (DIR)) {
X				next				if ($subfile eq '.' || $subfile eq '..');
X				push (@files, "$file/$subfile");
X			}
X
X			&trace ('closedir', $file)		if ($trace_p);
X			closedir (DIR);
X
X			unshift (@dirstack, $file);
X		}
X	}
X
X	foreach $dir (@dirstack) {
X		&trace ('rmdir', $dir)				if ($trace_p);
X		$ret2 = rmdir ($dir);
X		if (!$ret2) {
X			$ret++;
X			warn "$prog: rmdir $dir: $!\n";
X		}
X	}
X
X	$ret;
X}
X
X
X# Function to copy a file
X# Arg 1 is the destination file
X# Arg 2 is the source file
X# Arg 3 is the mode, if not passed, use the source file mode
X# Arg 4 is true if the file should not be deleted first in doing the copy.
X# Arg 5 is a bitmask to OR  the mode with (to add permission bits)
X# Arg 6 is a bitmask to AND the mode with (to remove permission bits)
X# Arg 7 is true if we should copy a symlink'ed file instead of propigating the symlink.
X
Xsub copy_file {
X	local ($nargs)			= scalar (@_);
X	die "$prog: copy_file called with $nargs arguments.\n"	if ($nargs < 2 || $nargs > 7);
X
X	local ($package, $csrc, $line)	= caller;
X	local ($dest)			= shift (@_);
X	local ($src)			= shift (@_);
X	local ($mode)			= shift (@_);
X	local ($no_delete)		= shift (@_);
X	local ($mode_or)		= shift (@_);
X	local ($mode_and)		= shift (@_);
X	local ($no_symlink)		= shift (@_);
X	local ($dev, $inode);
X
X	$no_delete = 0						if (! defined ($no_delete));
X	&delete_file ($dest)					if (-e $dest && !$no_delete);
X
X	if (-l $src && !$no_symlink) {
X		local ($link) = readlink ($src);
X		&trace ('ln', '-s', $link, $dest)		if ($trace_p);
X		symlink ($link, $dest)				|| die "$prog: ln -s $link $dest_file: $!\n";
X
X	} elsif (-d _ || (-l _ && -d $src)) {
X		local (@files)		= ();
X		local ($src_file)	= undef;
X		local ($dest_file)	= undef;
X
X		if (! defined ($mode)) {
X			local ($dev, $inode);
X
X			($dev, $inode, $mode) = stat (_);
X			$mode &= 07777;
X		}
X
X		$mode |= $mode_or				if (defined ($mode_or));
X		$mode &= $mode_and				if (defined ($mode_and));
X		
X		# Copy all files into a local array, so that the DIR file handle doesn't get
X		# clobbered if we are handling an entire directory tree.
X		# Also we don't deal with linked files in the directory at this time.
X
X		&make_directory ($dest, 0700);
X		&trace ('opendir', $src)			if ($trace_p);
X		opendir (DIR, $src)				|| die "$prog: opendir $src: $!\n";
X		@files = grep ($_ ne '.' && $_ ne '..', readdir (DIR));
X		&trace ('closedir', $src)			if ($trace_p);
X		closedir (DIR);
X
X		foreach $file (@files) {
X			$src_file  = join ('/', $src,  $file);
X			$dest_file = join ('/', $dest, $file);
X			&copy_file ($dest_file, $src_file, undef, $no_delete, $mode_or, $mode_and, $no_symlink);
X		}
X
X		&change_mode ($mode, $dest);
X
X	} else {
X		local (@stat)		= stat (_);		# stat done above for -d/-l
X		local ($file_bufsize)	= ($stat[$main'ST_BLKSIZE] > $bufsize) ? $stat[$main'ST_BLKSIZE] : $bufsize;
X		local ($dest_fix)	= &fix_file ($dest, '>', $package);
X		local ($src_fix)	= &fix_file ($src,  '<', $package);
X		local ($len)		= undef;
X		local ($buf)		= "\0" x $file_bufsize;
X
X		if (! defined ($mode)) {
X			local ($dev, $inode);
X
X			($dev, $inode, $mode) = stat (_);
X			$mode &= 07777;
X		}
X
X		$mode |= $mode_or				if (defined ($mode_or));
X		$mode &= $mode_and				if (defined ($mode_and));
X
X		open (INP, $src_fix)				|| die "$prog: open $src: $!\n";
X		open (OUT, $dest_fix)				|| die "$prog: open $dest: $!\n";
X
X		&trace (sprintf ("copy [mode 0%03o] %s %s%s",
X				 $mode, $src, $dest,
X				 (($no_delete) ? ', no delete' : '')))	if ($trace_p);
X
X		while ($len = sysread (INP, $buf, $file_bufsize)) {
X			if (! defined ($len)) {
X				next				if ($! =~ /^Interrupted/);
X				die "$prog: read error: $!\n";
X			}
X
X			$offset = 0;
X			while ($len) {
X				$written = syswrite (OUT, $buf, $len, $offset);
X				die "$prog: write error: $!\n"	unless defined ($written);
X
X				$len -= $written;
X				$offset += $written;
X			}
X		}
X	
X		close (INP);
X		close (OUT);
X
X		&change_mode ($mode, $dest);
X	}
X}
X
X
X# Function to compare two files, returning 0 if they are equal, != 0 otherwise.
X# Argument 1 is a file to compare.
X# Argument 2 is a file to compare.
X# Argument 3 is an optional timestamp to assume the files are equal if both older than it
X
X# Taken from dcmp, but hacked upon since then.
X
Xsub compare_files {
X	local ($nargs)			= scalar (@_);
X	die "$prog: compare_files called with $nargs arguments.\n" if ($nargs < 2 || $nargs > 3);
X
X	local ($package, $src, $line)	= caller;
X	local ($file_a)			= &fix_file (shift (@_), '', $package);
X	local ($file_b)			= &fix_file (shift (@_), '', $package);
X	local ($last_change_time)	= shift (@_);
X	local ($ret)			= 0;
X	local ($done)			= 0;
X	local ($len_a, $len_b);
X	local ($buf_a, $buf_b);
X	local (@stat_a);
X	local (@stat_b);
X	local ($len_a);
X	local ($len_b);
X	local ($bufsize_a);
X	local ($bufsize_b);
X	local ($file_bufsize);
X
X	&trace ('compare', $file_a, $file_b)			if ($trace_p);
X
X
X	if (! (@stat_a = stat ($file_a))) {
X		$ret = 2;
X		$done = 1;
X		&trace ("stat error: $file_a: $!")		if ($trace_p);
X
X	} elsif (! (@stat_b = stat ($file_b))) {
X		$ret = 2;
X		$done = 1;
X		&trace ("stat error: $file_b: $!")		if ($trace_p);
X	}
X
X	$len_a = $stat_a[ $[ + $main'ST_SIZE];
X	$len_b = $stat_b[ $[ + $main'ST_SIZE];
X
X	# Don't bother actually reading the file if we know it isn't equal
X	if ($done) {						# error above in doing stats
X
X	} elsif ($len_a != $len_b) {				# files have different lengths
X		$ret = 1;
X		$done = 1;
X
X	} elsif ($len_a == 0) {					# zero length files
X		$ret = 0;
X		$done = 1;
X
X	} elsif (defined ($last_change_time) && $last_change_time
X		 && $stat_a[$ST_MTIME] < $last_change_time
X		 && $stat_b[$ST_MTIME] < $last_change_time) {	# files modified before some time delta
X
X		$ret = 0;
X		$done = 1;
X	}
X
X
X	if (! $done) {
X		$bufsize_a = ($stat_a[$main'ST_BLKSIZE] > $bufsize) ? $stat[$main'ST_BLKSIZE] : $bufsize;
X		$bufsize_b = ($stat_b[$main'ST_BLKSIZE] > $bufsize) ? $stat[$main'ST_BLKSIZE] : $bufsize;
X		$file_bufsize = ($bufsize_a > $bufsize_b) ? $bufsize_a : $bufsize_b;
X
X		$buf_a = "\0" x $file_bufsize;
X		$buf_b = "\0" x $file_bufsize;
X
X		open (FILE_A, $file_a)				|| die "$prog: open $file_a: $!\n";
X		open (FILE_B, $file_b)				|| die "$prog: open $file_b: $!\n";
X
X		while (! $done) {
X			$len_a = sysread (FILE_A, $buf_a, $file_bufsize);
X
X			if (! defined ($len_a)) {
X				next				if ($! =~ /^Interrupted/);
X				die "$prog: read error on $file_a: $!\n";
X			}
X
X			while () {
X				$len_b = sysread (FILE_B, $buf_b, $file_bufsize);
X				last				if (defined ($len_b));
X				next				if ($! =~ /^Interrupted/);
X				die "$prog: read error on $file_b: $!\n";
X			}
X
X			last					if ($len_a == 0 && $len_b == 0);
X			next					if ($len_a == $len_b && $buf_a eq $buf_b);
X
X			$ret = 1;
X			$done = 1;
X		}
X	}
X
X	&trace (($ret) ? 'files are not equal.' : 'files are equal.')	if ($trace_p);
X	$ret;
X}
X
X
X# Make sure require does not abort
X1;
SHAR_EOF
chmod 0664 mrm-files.pl ||
echo 'restore of mrm-files.pl failed'
Wc_c="`wc -c < 'mrm-files.pl'`"
test 9717 -eq "$Wc_c" ||
	echo 'mrm-files.pl: original size 9717, current size' "$Wc_c"
fi
# ============= mrm-eval.pl ==============
if test -f 'mrm-eval.pl' -a X"$1" != X"-c"; then
	echo 'x - skipping mrm-eval.pl (File already exists)'
else
echo 'x - extracting mrm-eval.pl (Text)'
sed 's/^X//' << 'SHAR_EOF' > 'mrm-eval.pl' &&
X#! /usr/local/bin/perl
X
X{
X	package main;
X
X	require 'mrm-export.pl';
X
X	&export ('mrm_eval', $EXPORT_FUNCTION, 'eval_or_die');
X	&import ('mrm_eval', $IMPORT_FUNCTION, 'trace');
X	&import ('mrm_eval', $IMPORT_VARIABLE, 'trace_p');
X
X	$EXPORT_FUNCTION || $IMPORT_FUNCTION || $IMPORT_VARIABLE;	# silence perl -w
X}
X
Xpackage mrm_eval;
X$prog = substr ($0, rindex ($0, '/') + 1);
X
X# Function to evaluate a string, and die if it failed.  Because of the
X# way export_functions work, the pogo to eval_or_die will be in the
X# package of the caller (ie, main typically), so the package
X# declaration will be correct, unless the user does something like:
X#
X#	package foo;
X#	&main'eval_or_die ('...');
X
Xsub eval_or_die {
X	local ($package, $filename, $line)	= caller;
X	local (@add_package)			= ($_[$[] =~ /^\s*package/) ? () : ("package $package; ");
X	local ($eval_string)			= join ('', @add_package, @_);
X
X	&trace ("eval", "'$eval_string'")	if ($trace_p);
X	eval ($eval_string);
X	die "$prog: eval error: $@, string =\n$eval_string\n"	if ($@);
X}
SHAR_EOF
chmod 0644 mrm-eval.pl ||
echo 'restore of mrm-eval.pl failed'
Wc_c="`wc -c < 'mrm-eval.pl'`"
test 1026 -eq "$Wc_c" ||
	echo 'mrm-eval.pl: original size 1026, current size' "$Wc_c"
fi
# ============= mrm-export.pl ==============
if test -f 'mrm-export.pl' -a X"$1" != X"-c"; then
	echo 'x - skipping mrm-export.pl (File already exists)'
else
echo 'x - extracting mrm-export.pl (Text)'
sed 's/^X//' << 'SHAR_EOF' > 'mrm-export.pl' &&
X#! /usr/local/bin/perl
X
X# Perl script to manage exporting and importing of symbols between packages
X
Xpackage export;
X
X{
X	$prog	    = substr ($0, rindex ($0, '/') + 1);
X	%exports    = ();
X	%imports    = ();
X	$trace_init = 0;
X	$func	    = undef;
X	$trace_p    = $ENV{'TRACE_ENABLE'} || 0			if (! defined ($trace_p));
X	$filename   = $ENV{'TRACE_FILENAME'} || '>>&STDERR'	if (! defined ($filename));
X	$filename   = "&$filename"				if ($filename =~ /^\d+$/);
X	$filename   = &fix_file ($filename, '>', 'main');
X
X	$EXPORT_NONE	 = 0;
X	$EXPORT_FUNCTION = 1;
X	$EXPORT_VARIABLE = 2;
X
X	$IMPORT_VARIABLE = 0;
X	$IMPORT_FUNCTION = 1;
X
X	&export ('export', $EXPORT_FUNCTION,			# functions exported
X		 'export',
X		 'import',
X		 'timestamp',
X		 'trace',
X		 'fix_file',
X		 'unfix_file',
X		 'trace_enable');
X
X	&export ('export', $EXPORT_VARIABLE,			# variables exported
X		 'EXPORT_NONE',
X		 'EXPORT_VARIABLE',
X		 'EXPORT_FUNCTION',
X		 'IMPORT_VARIABLE',
X		 'IMPORT_FUNCTION',
X		 'trace_p');
X}
X
X
X# Export symbols from a package.
X# Argument 1 is the package name symbols are in
X# Argument 2 is 0 if the symbols should not be exported to the main as functions (just put in database).
X# The remaining arguments are symbol names to export
X
Xsub export {
X	local ($nargs)	= scalar (@_);
X	die "$prog: export called with $nargs arguments.\n" if ($nargs < 3);
X
X	local ($package)	= shift (@_);
X	local ($do_export)	= shift (@_);
X	local (@errors)		= ();
X	local ($export_package)	= undef;
X	local ($main_p)		= $package eq 'main';
X	local ($import_flag)	= ($do_export <= $EXPORT_FUNCTION) ? $IMPORT_FUNCTION : $IMPORT_VARIABLE,
X
X
X	&trace ('export', $package, $do_export, @_)		if ($trace_p);
X
X	foreach $symbol (@_) {
X		$export_package = $exports{$symbol};
X		if (defined $export_package) {
X			if ($export_package ne $package) {
X				push (@errors, "${symbol} is already defined in package ${export_package}\n");
X			}
X
X			next;
X		}
X
X		$exports{$symbol} = $package;
X	}
X
X	if (scalar (@errors) > 0) {
X		die join ('', "$prog: export errors:\n", @errors);
X	}
X
X	&import ('main', $import_flag, @_)			if ($do_export && !$main_p);
X
X	1;
X}
X
X
X# Function to import a bunch of symbols from one package to the caller's package.
X# Argument 1 is the package to import the symbols into.
X# Argument 2 is non-zero if build a function to call the real func, otherwise use a reference
X# The remaining arguments are the symbols to be imported.
X
Xsub import {
X	local ($nargs)	= scalar (@_);
X	die "$prog: import called with $nargs arguments.\n" if ($nargs < 3);
X
X	local ($package)		= shift (@_);
X	local ($func_p)			= shift (@_);
X	local ($;)			= "\034";
X	local (@eval)			= ();
X	local (@errors)			= ();
X	local ($export_package)		= undef;
X
X	&trace ('import', $package, $func_p, @_)		if ($trace_p);
X
X	foreach $symbol (@_) {
X		next						if (defined $imports{ $package, $symbol });
X
X		$export_package = $exports{ $symbol };
X		if (! defined $export_package) {
X			push (@errors, "${symbol} symbol has not been exported yet.\n");
X			next;
X
X		} elsif ($export_package eq $package) {
X			push (@errors, "${symbol} is both imported/exported to ${package}.\n");
X			next;
X		}
X		
X		$imports{ $package, $symbol } = $package;
X		push (@eval, ($func_p)
X				? "\tsub ${symbol} { &${export_package}'${symbol}; }\n"
X				: "\t*${symbol} = *${export_package}'${symbol};\n");
X	}
X
X	if (scalar (@eval) > 0) {
X		local ($estr) = join ('', "\tpackage ${package};\n", @eval);
X		&trace ("import eval:\n$estr")			if ($trace_p);
X		eval $estr;
X		push (@errors, "eval error $@\n$estr")		if ($@);
X	}
X
X	if (scalar (@errors) > 0) {
X		die join ('', "$prog: import errors:\n", @errors);
X	}
X
X	1;
X}
X
X
X# Generate a timestamp
X
Xsub timestamp {
X	local ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime (time);
X	sprintf ("%02d:%02d:%02d [%05d]", $hour, $min, $sec, $$);
X}
X
X
X# Trace some information if the trace flag is set.
X
Xsub trace {
X	return							if (! $trace_p);
X
X	# Initialize the first time or after a call to trace_enable
X	if (!$trace_init) {
X		local ($oldfh)		= undef;
X
X		$filename =~ s/^/>>/				if ($filename !~ /^[>]/);
X		$trace_file = '';
X		open ($trace_file, $filename)			|| die "$0: open $filename: $!\n";
X		$oldfh = select($trace_file);
X		$| = 1;
X		select($oldfh);
X		$trace_init = 1;
X
X		&trace ('tracing started.');
X	}
X
X	# If the user defined his/her own tracing function, use that with our args
X	if (defined ($func)) {
X		&$func;						# pass arguments straight through
X
X	} else {
X		local ($\, $,) = ("\n", ' ');
X		print $trace_file (&timestamp (), @_);
X	}
X}
X
X
X# Function to fix up a filename by prepending a > or < to it if it
X# doesn't already have one, and also handling &name without a package
X# qualifier.
X
Xsub fix_file {
X	local ($nargs) = scalar (@_);
X	die "$0: fix_file called with $nargs arguments.\n"	if ($nargs != 3);
X
X	local ($file, $prefix, $package) = @_;
X
X	return $file						if (!defined ($file));
X
X	substr ($file, $[, 0) = $prefix				if (length ($prefix) > 0
X								    && $file !~ /(^\+?[\|\<\>].*|\|)$/);
X
X	$file = "${1}${package}'${2}"				if ($file =~ /^([<>]+&)([^']+)$/);
X	$file;
X}
X
X
X# Function to remove the initial < or >
X
Xsub unfix_file {
X	local ($nargs) = scalar (@_);
X	die "$0: unfix_file called with $nargs arguments.\n"	if ($nargs != 1);
X
X	local ($file) = shift (@_);
X
X	$file =~ s/^[<>]+//;
X	$file;
X}
X
X
X# Set trace flag, function and/or filename
X
Xsub trace_enable {
X	local ($flag, $name, $new_func)	= @_;
X	local ($package, $src, $line)	= caller;
X	local ($old_trace)		= $trace_p;
X	local ($old_filename)		= $filename;
X
X	$flag = 1						unless (defined ($flag));
X	$trace_p = $flag;
X	&trace ('tracing stopped.')				if ($trace_init && $old_trace && !$flag);
X
X	if (defined ($name)) {
X		$name = &fix_file ($name, '>', $package);
X		if ($trace_init && $name ne $filename) {
X			close ($trace_file)			|| die "$0: close $filename: $!\n";
X			$filename = $name;
X			$trace_init = 0;
X		}
X	}
X
X	if (defined ($new_func)) {
X		$new_func =~ s/^/$package'/			if ($new_func !~ /'/);
X		$func = $new_func;
X	}
X
X	&trace ('tracing started.')				if ($trace_p
X								    && (!$old_trace || $filename ne $old_filenaem));
X}
X
X
X# Return a true value to require
X
X1;
SHAR_EOF
chmod 0644 mrm-export.pl ||
echo 'restore of mrm-export.pl failed'
Wc_c="`wc -c < 'mrm-export.pl'`"
test 6078 -eq "$Wc_c" ||
	echo 'mrm-export.pl: original size 6078, current size' "$Wc_c"
fi
exit 0
--
Michael Meissner	email: meissner@osf.org		phone: 617-621-8861
Open Software Foundation, 11 Cambridge Center, Cambridge, MA, 02142

You are in a twisty little passage of standards, all conflicting.
Newsgroups: comp.lang.perl