From: mmuegel@next3.corp.mot.com (Michael S. Muegel)
Subject: Re: copy() primitive?
Organization: Corporate Information Office, Schaumburg, Illinois, Motorola, Inc.
Date: Sun, 20 Dec 1992 06:08:58 GMT

Previously, aahz@hal.COM (Tom Wylie) wrote:
> 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.

Keep things minimal I guess (hey, don't all you Perl people laugh *too*
loud when I say that ;-). If I am doing something like cp often I
always write a function to do the work since I am a stickler for error
detection.

Here are a set of libraries I wrote to help do file stuff. I wrote them
a long time ago (with a few updates) so they may not be pretty (not in
a package, for instance). Also, I mispelled maybe throught one of the
libraries.

Hope someone finds them useful, though. Constructive comments always welcome.

Cheers,
-Mike

---- Cut Here and feed the following to sh ----
#!/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/20/1992 06:03 UTC by mmuegel@mot.com (Michael S. Muegel)
# Source directory /usr/local/ustart-all/NeXT/contrib/lib/perl
#
# existing files will NOT be overwritten unless -c is specified
#
# This shar contains:
# length  mode       name
# ------ ---------- ------------------------------------------
#  10640 -r--r--r-- fileop.pl
#   2954 -r--r--r-- fileinfo.pl
#
# ============= fileop.pl ==============
if test -f 'fileop.pl' -a X"$1" != X"-c"; then
	echo 'x - skipping fileop.pl (File already exists)'
else
echo 'x - extracting fileop.pl (Text)'
sed 's/^X//' << 'SHAR_EOF' > 'fileop.pl' &&
;# NAME
;#    fileop.pl - perl function(s) create, remove, copy, and change mode of 
;#		  file system objects
;#
;# DESCRIPTION
;#    &Maybee_Delete_Path, &Create_Symlink, and &Create_Dir share 3 common 
;#    arguments: $Override_If_Link, $Override_If_File, and $Override_If_Dir.
;#    They have the following meaning where Path is the object that will be 
;#    created:
;#
;#       If Path is a link:
;#          + The operation will be forced if $Override_If_Link is TRUE
;#          + The operation will not be created otherwise
;#
;#       If Path is a file:
;#          + The operation will be forced if $Override_If_File is TRUE
;#          + The operation will not be created otherwise
;#
;#       If Path is a directory:
;#          + The operation will be forced if $Override_If_Dir is TRUE
;#          + The operation will not be created otherwise
;#
;#       If Path does not exist at all:
;#          + The directory will always be created
;#
;#    They all return the same thing, a ($Status, $Msg) pair where $status is:
;#
;#       -1 	The action could not be performed because a condition for 
;#		the action was not met. $Msg tells why not.
;#
;#       0 	The action could not be performed because of an error. $Msg 
;#		tells what happened.
;#
;#    	 1 	The action was successfuly perfomed. $Msg tells what we did.
;#
;# AUTHOR
;#    Michael S. Muegel (mmuegel@mot.com)
;#
;# RCS INFORMATION
;#    $Author: mmuegel $
;#    $Header: /usr/local/ustart/src/perl-stuff/libs/fwrdc/misc/RCS/fileop.pl,v 1.6 1992/11/02 02:58:21 mmuegel Exp $
X
require "fileinfo.pl";
X
;###############################################################################
;# Maybee_Delete_Path
;#
;# Deletes $Path depending on the Delete arguments. $Msg is a message
;# saying what deltion occured (null if none). $Type is set to "link", 
;# "directory", "file", or "" depending on whether $Path was any of them.
;# Finally, $Status is:
;#
;#   -1 if a deletion was necess. but failed
;#    0 if a delete was not necess
;#    1 if a delete was necess and succeeded
;#
;# Arguments:
;#    $Path, $Delete_If_Link, $Delete_If_File, $Delete_If_Dir
;#
;# Returns:
;#    $Status, $Type, $Msg
;###############################################################################
sub Maybee_Delete_Path
{
X   local ($Path, $Delete_If_Link, $Delete_If_File, $Delete_If_Dir) = @_;
X   local ($Type, $Msg);
X
X   # Check for existing link
X   if (-l $Path)
X   {
X      $Type = "link";
X      return (-1, $Type, "$Path is already a link") if (! $Delete_If_Link);
X   } 
X
X   # Need to isolate these, really...
X   else
X   {
X      # Check for existing file/directory
X      if (-d $Path)
X      {
X         $Type = "directory";
X         return (-1, $Type, "$Path is a directory") if (! $Delete_If_Dir);
X      };
X      if (-f _)
X      {
X         $Type = "file";
X         return (-1, $Type, "$Path is a file") if (! $Delete_If_File);
X      };
X   };
X
X   # Delete $Path if necess.
X   if ($Type)
X   {
X      return (-1, $Type, "could not remove old $Type $Path") 
X         if (system ("/bin/rm -r $Path"));
X      $Msg = "removed $Type $Path";
X      return (0, $Type, $Msg);
X   };
X
X   return (1, $Type, $Msg);
};
X
X
;###############################################################################
;# Create_Symlink
;#
;# Creates a symbolic link from $Link_From -> $Link_To. Note that the link will
;# NOT be no matter what the Ovveride's are set to if it would result in a 
;# recursive link. May delete an old  $Link_To depending on the Override 
;# arguments.
;#
;# Arguments:
;#    $Link_To, $Link_From, $Override_If_Link, $Override_If_File,
;#    $Override_If_Dir
;#
;# Returns:
;#    $Status, $Msg
;###############################################################################
sub Create_Symlink
{
X   local ($Link_To, $Link_From, $Override_If_Link, $Override_If_File,
X          $Override_If_Dir) = @_;
X   local ($Remove, $Type, $Msg, $Link_From_Real, $Link_To_Real, 
X          $Link_From_Basename, $Link_From_Dir, $Real_Path, $Status);
X
X   # Determine whether $Link_From and $Link_To point to the same object!
X   ($Link_From_Basename = $Link_From) =~ s/.*\///;
X   $Link_From_Dir = &Dir_Name ($Link_From);
X   return (0, $Real_Path) if (! (($Status, $Real_Path) = &Real_Path ($Link_From_Dir))[0]);
X   chop ($Real_Path) if ($Real_Path =~ /^(\/){1,2}$/);
X   $Link_From_Real = "$Real_Path/$Link_From_Basename";
X   $Link_To_Real = "$Link_From_Dir/$Link_To" if ($Link_To !~ /^\//);
X   return (0, $Link_To_Real) if (! (($Status, $Link_To_Real) = &Real_Path ($Link_To_Real))[0]);
X   return (0, "$Link_From -> $Link_To would be a recursive link") 
X      if ($Link_From_Real eq $Link_To_Real);
X
X   # Possibly delete $Link_To
X   return (-1, $Msg) 
X      if ((($Status, $Type, $Msg) = &Maybee_Delete_Path ($Link_From, $Override_If_Link, $Override_If_File,
X                                                         $Override_If_Dir))[0] == -1);
X
X   # Create the link!
X   $Msg .= ", " if ($Msg);
X   return (0, "${Msg}error creating link $Link_From -> $Link_To") 
X      if (! symlink ($Link_To, $Link_From));
X   return (1, "${Msg}created link $Link_From -> $Link_To");
};
X
X
;###############################################################################
;# Create_Dir
;#
;# Creates a directory $Path. May delete an old $Path depending on the
;# Override arguments. Uses $Mode as the mode of the directory. $Mode had better
;# be in octal!!
;#
;# Arguments:
;#    $Path, $Mode, $Override_If_Link, $Override_If_File, $Override_If_Dir
;#
;# Returns:
;#    $Status, $Msg
;###############################################################################
sub Create_Dir
{
X   local ($Path, $Mode, $Override_If_Link, $Override_If_File, 
X          $Override_If_Dir) = @_;
X   local ($Status, $Msg);
X
X   # Possibly delete $Link_To
X   return (-1, $Msg) 
X      if ((($Status, $Type, $Msg) = &Maybee_Delete_Path ($Path, $Override_If_Link, $Override_If_File,
X                                                         $Override_If_Dir))[0] == -1);
X
X   # Convert a mode in form 0[0-9]{1,3} to cotal because it must be ASCII
X   $Mode = oct ($Mode) if ($Mode =~ /^0/);
X
X   # Create the directory
X   $Msg .= ", " if ($Msg);
X   return (0, "${Msg}error directory $Path") 
X      if (! mkdir ($Path, $Mode));
X   return (1, "${Msg}created directory $Path");
};
X
;###############################################################################
;# Change_File_Info
;#
;# This function can change the owner, group, and modes of a file or directory.
;# It will only perform these operations if the function arguments are
;# not -1. As an example, the following will change the mode and group
;# of a file and leave the owner unchanged:
;#
;#    ($Status, $Msg) = &Change_FIle_Info ($File, 0555, -1, "staff", 1)
;#
;# By default this function requires numerical user and group IDs. However, if
;# $Lookup_IDs is 1 then the $Owner and $Group will be interpreted as
;# actual login names or group names.
;#
;# Returns with a $Status of 1 if everything went AOK; otherwise, $Status is
;# 0 and $Msg contains an error message.
;#
;# Arguments:
;#    $Path, $Mode, $Owner, $Group, $Lookup_IDs
;#
;# Returns:
;#    $Status, $Msg
;###############################################################################
sub Change_File_Info
{
X   local ($Path, $Mode, $Owner, $Group, $Lookup_IDs) = @_;
X   local ($Uid, $Gid);
X
X   # Change owner and/or mode
X   if (($Owner != -1) || ($Group != -1))
X   {
X      # Get the default owner and group of the file
X      (($Uid, $Gid) = (stat ($Path))[4,5]) || return (0, "error stating $Path");
X
X      # Override the default owner?
X      if ($Owner != -1)
X      {
X         if ($Lookup_IDs)
X         {
X            $Uid = (getpwnam ($Owner))[2];
X   	    return (0, "no such user: $Owner") if ($Uid eq "");
X         }
X	 else
X         {
X            $Uid = $Owner;
X         };
X      };
X
X      # Override the default group?
X      if ($Group != -1)
X      {
X         if ($Lookup_IDs)
X         {
X   	    $Gid = (getgrnam ($Group))[2];
X	    return (0, "no such group: $Group") if ($Gid eq "");
X         }
X         else
X         {
X            $Gid = $Group;
X         };
X      };
X
X      # Change owner/group
X      chown ($Uid, $Gid, $Path) || return (0, "error changing owner/group of $Path");
X   };
X
X   # Change mode
X   if ($Mode != -1)
X   {
X      $Mode = oct ($Mode) if ($Mode =~ /^0/);
X      chmod ($Mode, $Path) || return (0, "error changing mode of $Path");
X   };
X
X   return (1);
};
X
X
;###############################################################################
;# Copy_File
;#
;# Copies $Source to $Dest. If $Mode, $Owner, or $Group are -1 their default
;# values are used. Their default will be computed via the umask, ACLs,
;# etc or, if $Preserve is 1, the mode, owner, and group of the original file
;# is maintained. When $Preserve $Mode, $Owner, or $Group are ignored as you
;# would expect.
;#
;# By default this function requires numerical user and group IDs. However, if
;# $Lookup_IDs is 1 then the $Owner and $Group will be interpreted as
;# actual login names or group names.
;#
;# If $Force is 1 any pre-existing destination file will be overriden even
;# if the file is read only.
;#
;# Returns with a $Status of 1 if everything went AOK; otherwise, $Status is
;# 0 and $Msg contains an error message.
;#
;# Arguments:
;#    $Source, $Dest, $Preserve, $Mode, $Owner, $Group, $Lookup_IDs,
;#    $Force
;#
;# Returns:
;#    $Status, $Msg
;###############################################################################
sub Copy_File
{
X   local ($Source, $Dest, $Preserve, $Mode, $Owner, $Group, $Lookup_IDs,
X	  $Force) = @_;
X   local ($Output);
X
X   # If the dest file exists and is not writable ...
X   # mode.
X   if ((-f $Dest) && (! -w $Dest))
X   {
X      # If not force mode copy will fail
X      return (0, "$Dest is not writable") if (! $Force);
X
X      # Force mode, try to change the mode. We can only change its mode if 
X      # we own it
X      if ((stat (_))[4] == $>)
X      {
X         system ("chmod u+w $Dest") && return (0, "error making $Dest writable to owner");
X      }
X      else
X      {
X         return (0, "$Dest is not writable and you do not own it");
X      };
X   };
X
X   # Copy
X   $Output = `/bin/sh -c 'cp $Source $Dest' 2>&1`;
X   $Output =~ s/\n$//;
X   return (0, $Output) if ($Output);
X
X   # If we want to change the mode of the destination to match the source
X   # then we need to stat() it
X   if ($Preserve)
X   {
X      (($Mode, $Owner, $Group) = (stat ($Source))[2,4,5]) || return (0, "error stating $Source");
X      $Lookup_IDs = 0;
X   };
X
X   # Change the uid, gid, or mode of the destination
X   return &Change_File_Info ($Dest, $Mode, $Owner, $Group, $Lookup_IDs);
};
X
X
1;
SHAR_EOF
chmod 0444 fileop.pl ||
echo 'restore of fileop.pl failed'
Wc_c="`wc -c < 'fileop.pl'`"
test 10640 -eq "$Wc_c" ||
	echo 'fileop.pl: original size 10640, current size' "$Wc_c"
fi
# ============= fileinfo.pl ==============
if test -f 'fileinfo.pl' -a X"$1" != X"-c"; then
	echo 'x - skipping fileinfo.pl (File already exists)'
else
echo 'x - extracting fileinfo.pl (Text)'
sed 's/^X//' << 'SHAR_EOF' > 'fileinfo.pl' &&
;# NAME
;#    fileinfo.pl - perl function(s) give information on file system objects
;#
;# AUTHOR
;#    Michael S. Muegel (mmuegel@mot.com)
;#
;# RCS INFORMATION
;#    $Author: mmuegel $
;#    $Header: /usr/local/lib/perl/RCS/fileinfo.pl,v 1.1 1991/10/28 14:42:01 mmuegel Exp $
;#    $Source: /usr/local/lib/perl/RCS/fileinfo.pl,v $
X
;###############################################################################
;# Dir_Name
;#
;# Returns the name of the directory that $Path is in. The name is the
;# logical name. E.g. no link following is done.
;#
;# Written by me@anywhere.EBay.Sun.COM (Wayne Thompson) and posted to c.l.p.
;# Modified to work with Domain/OS // filesystem.
;#
;# Arguments:
;#    $Path
;#
;# Returns:
;#    $Dir
;###############################################################################
sub Dir_Name 
{   
X    local ($_) = @_;
X    local ($return);
X    s#$#/#;
X    (($return) = m#^(/[/]?)[^/]*/$#) ||
X        (($return) = m#(.*[^/])/+[^/]+/+$#) ||
X        ($return = '.');
X    $return;
};
X
X
;###############################################################################
;# Real_Path
;#
;# Determines the actual physical path of $Path. It will follow links if
;# necessary. When sitting in my $HOME and given "bin" will return
;# //fwase12/users/mmuegel/bin. Returns with $Status TRUE if it was able to
;# compute the real path; FALSE otherwise. If FALSE an error string is returned
;# instead of the pathname. Catches recursive links by setting a limit on the 
;# number of times a pathname can be encountered. The maximum number is 
;# $MAX_VISITS.
;#
;# Arguments:
;#    $Path
;#
;# Returns:
;#    $Status, $Real_Path
;###############################################################################
sub Real_Path
{
X   local ($Logical_Path) = @_;
X   local (%Traversed_Count);
X   local ($MAX_VISITS) = 8;
X   local ($PWD) = "/bin/pwd";
X
X   sub Real_Path_Rec
X   {
X      local ($Path) = @_;
X      local ($Basename, $Dir, $New_Path, $Real_Path, $Error);
X
X      # Check for recursion
X      return (0, "$Logical_Path: possible recursion for object $Path") 
X         if ($Traversed_Count {$Path}++ == $MAX_VISITS);
X
X      # Get the basename and directory $Path is in
X      ($Basename = $Path) =~ s/.*\///;
X      $Dir = &Dir_Name ($Path);
X      
X      # Collapse //node/.. -> // because of bug in Domain/OS
X      $Dir =~ s#^//[^/]+/\.\.#//#;
X
X      # Change to the directory $Path is in
X      chdir ($Dir) || return (0, "$Logical_Path: could not chdir to $Dir: $!") if ($Dir ne ".");
X      chop ($Dir = `$PWD`) || return (0, "$Logical_Path: can not find current working directory: $!");
X   
X      if (-l $Basename)
X      {
X         $New_Path = readlink ($Basename) || return (0, "$Logical_Path: can not read link $Path/$Basename");
X         return (&Real_Path_Rec ($New_Path));
X      };
X   
X      chop ($Dir) if ($Dir =~ /^(\/){1,2}$/);
X      return (1, "$Dir/$Basename");
X   };
X
X   return (&Real_Path_Rec ($Logical_Path));
X
};
X
1;
SHAR_EOF
chmod 0444 fileinfo.pl ||
echo 'restore of fileinfo.pl failed'
Wc_c="`wc -c < 'fileinfo.pl'`"
test 2954 -eq "$Wc_c" ||
	echo 'fileinfo.pl: original size 2954, current size' "$Wc_c"
fi
exit 0
-- 
+----------------------------------------------------------------------------+
| Michael S. Muegel                  | Internet:    mmuegel@mot.com          |
| UNIX Applications Startup Group    | Moto X.400:  X10090                   |
| Corporate Information Office       | Voice:       (708) 576-0507           |
| Motorola, Inc.                     | ... these are my opinions, honest ... |
+----------------------------------------------------------------------------+