home *** CD-ROM | disk | FTP | other *** search
/ NetNews Usenet Archive 1992 #30 / NN_1992_30.iso / spool / comp / lang / perl / 7561 / mrm-files.pl < prev   
Encoding:
Perl Script  |  1992-12-21  |  9.5 KB  |  363 lines
  1. #! /usr/local/bin/perl
  2.  
  3. # Subroutine library for common file related actions.
  4.  
  5. {
  6.     package main;
  7.     require 'stat.pl';
  8.     require 'mrm-export.pl';
  9.  
  10.     &export ('files', $EXPORT_FUNCTION,
  11.          'rename_file',
  12.          'change_mode',
  13.          'make_directory',
  14.          'delete_file',
  15.          'copy_file',
  16.          'compare_files');
  17.  
  18.     &import ('files', $IMPORT_FUNCTION, 'trace', 'fix_file', 'unfix_file');
  19.     &import ('files', $IMPORT_VARIABLE, 'trace_p');
  20.  
  21.     $EXPORT_FUNCTION || $IMPORT_FUNCTION || $IMPORT_VARIABLE;    # silence perl -w
  22. }
  23.  
  24. package files;
  25. $bufsize = 16384;
  26. $prog = substr ($0, rindex ($0, '/') + 1);
  27.     
  28.  
  29. # Function to rename a file, trace the result, and die if an error occurred.
  30.  
  31. sub rename_file {
  32.     local ($nargs)        = scalar (@_);
  33.     die "$prog: rename_file called with $nargs arguments.\n" if ($nargs != 2);
  34.  
  35.     local ($old, $new)    = @_;
  36.  
  37.     &delete_file ($new)                    if (-e $new);
  38.     &trace ('rename', $old, $new)                if ($trace_p);
  39.     rename ($old, $new)                    || die "$prog: rename $old $new: $!\n";
  40.     1;
  41. }
  42.  
  43.  
  44. # Function to change the mode on one or more files, and die if there was any errors
  45.  
  46. sub change_mode {
  47.     local ($nargs)        = scalar (@_);
  48.     die "$prog: change_mode called with $nargs arguments.\n" if ($nargs < 2);
  49.  
  50.     local ($mode, @files)    = @_;
  51.     local ($mode_octal)    = sprintf ("0%03o", $mode);
  52.     local (@errors)        = ();
  53.  
  54.     foreach (@files) {
  55.         &trace ('chmod', $mode_octal, $_)        if ($trace_p);
  56.         chmod ($mode, $_)                || push (@errors, "$prog: chmod $mode_octal $_: $!\n");
  57.     }
  58.  
  59.     die join ('', @errors)                    if (scalar (@errors) > 0);
  60.     1;
  61. }
  62.  
  63.  
  64. # Function to make a directory, trace the result, and die if an error occurred.
  65. # If any parent directories also don't exist, they are made too.
  66.  
  67. sub make_directory {
  68.     local ($nargs)        = scalar (@_);
  69.     die "$prog: make_directory called with $nargs arguments.\n" if ($nargs == 0 || $nargs > 2);
  70.  
  71.     local ($name)    = shift (@_);
  72.     local ($mode)    = (scalar (@_) > 0) ? shift (@_) : 0755;
  73.     local ($pmode)    = sprintf ("0%03o", $mode);
  74.     local (@pieces)    = split ('/', $name);
  75.     local ($dir)    = undef;
  76.     local ($i);
  77.  
  78.     for ($i = $[; $i <= $#pieces; $i++) {
  79.         $dir = join ('/', @pieces[ $[..$i ]);
  80.         next                        if ($dir eq '');
  81.  
  82.         if (! -d $dir) {
  83.             &trace ("mkdir", $dir, $pmode)        if ($trace_p);
  84.             mkdir ($dir, $mode)            || die "$prog: mkdir $dir $pmode: $!\n";
  85.         }
  86.     }
  87.  
  88.     1;
  89. }
  90.  
  91.  
  92. # Function to delete one or more files.
  93. # If any of the of files is a directory, delete all of it's contents.
  94. # Return value is the number of deletes that failed.
  95.  
  96. sub delete_file {
  97.     local (@files)        = @_;
  98.     local (@dirstack)    = ();
  99.     local ($ret)        = 0;
  100.     local ($ret2);
  101.     local ($file);
  102.     local ($subfile);
  103.  
  104.     while ($file = shift (@files)) {
  105.         if (-l $file || (-e _ && !-d _)) {
  106.             &trace ('unlink', $file)        if ($trace_p);
  107.             $ret2 = unlink ($file);
  108.             if (!$ret2) {
  109.                 $ret++;
  110.                 warn "$prog: unlink $file: $!\n";
  111.             }
  112.  
  113.         } elsif (-d _) {
  114.             &change_mode (0777, $file)        if (! -w _);
  115.  
  116.             &trace ('opendir', $file)        if ($trace_p);
  117.             opendir (DIR, $file)            || warn "$prog: opendir $file: $!\n";
  118.  
  119.             while ($subfile = readdir (DIR)) {
  120.                 next                if ($subfile eq '.' || $subfile eq '..');
  121.                 push (@files, "$file/$subfile");
  122.             }
  123.  
  124.             &trace ('closedir', $file)        if ($trace_p);
  125.             closedir (DIR);
  126.  
  127.             unshift (@dirstack, $file);
  128.         }
  129.     }
  130.  
  131.     foreach $dir (@dirstack) {
  132.         &trace ('rmdir', $dir)                if ($trace_p);
  133.         $ret2 = rmdir ($dir);
  134.         if (!$ret2) {
  135.             $ret++;
  136.             warn "$prog: rmdir $dir: $!\n";
  137.         }
  138.     }
  139.  
  140.     $ret;
  141. }
  142.  
  143.  
  144. # Function to copy a file
  145. # Arg 1 is the destination file
  146. # Arg 2 is the source file
  147. # Arg 3 is the mode, if not passed, use the source file mode
  148. # Arg 4 is true if the file should not be deleted first in doing the copy.
  149. # Arg 5 is a bitmask to OR  the mode with (to add permission bits)
  150. # Arg 6 is a bitmask to AND the mode with (to remove permission bits)
  151. # Arg 7 is true if we should copy a symlink'ed file instead of propigating the symlink.
  152.  
  153. sub copy_file {
  154.     local ($nargs)            = scalar (@_);
  155.     die "$prog: copy_file called with $nargs arguments.\n"    if ($nargs < 2 || $nargs > 7);
  156.  
  157.     local ($package, $csrc, $line)    = caller;
  158.     local ($dest)            = shift (@_);
  159.     local ($src)            = shift (@_);
  160.     local ($mode)            = shift (@_);
  161.     local ($no_delete)        = shift (@_);
  162.     local ($mode_or)        = shift (@_);
  163.     local ($mode_and)        = shift (@_);
  164.     local ($no_symlink)        = shift (@_);
  165.     local ($dev, $inode);
  166.  
  167.     $no_delete = 0                        if (! defined ($no_delete));
  168.     &delete_file ($dest)                    if (-e $dest && !$no_delete);
  169.  
  170.     if (-l $src && !$no_symlink) {
  171.         local ($link) = readlink ($src);
  172.         &trace ('ln', '-s', $link, $dest)        if ($trace_p);
  173.         symlink ($link, $dest)                || die "$prog: ln -s $link $dest_file: $!\n";
  174.  
  175.     } elsif (-d _ || (-l _ && -d $src)) {
  176.         local (@files)        = ();
  177.         local ($src_file)    = undef;
  178.         local ($dest_file)    = undef;
  179.  
  180.         if (! defined ($mode)) {
  181.             local ($dev, $inode);
  182.  
  183.             ($dev, $inode, $mode) = stat (_);
  184.             $mode &= 07777;
  185.         }
  186.  
  187.         $mode |= $mode_or                if (defined ($mode_or));
  188.         $mode &= $mode_and                if (defined ($mode_and));
  189.         
  190.         # Copy all files into a local array, so that the DIR file handle doesn't get
  191.         # clobbered if we are handling an entire directory tree.
  192.         # Also we don't deal with linked files in the directory at this time.
  193.  
  194.         &make_directory ($dest, 0700);
  195.         &trace ('opendir', $src)            if ($trace_p);
  196.         opendir (DIR, $src)                || die "$prog: opendir $src: $!\n";
  197.         @files = grep ($_ ne '.' && $_ ne '..', readdir (DIR));
  198.         &trace ('closedir', $src)            if ($trace_p);
  199.         closedir (DIR);
  200.  
  201.         foreach $file (@files) {
  202.             $src_file  = join ('/', $src,  $file);
  203.             $dest_file = join ('/', $dest, $file);
  204.             ©_file ($dest_file, $src_file, undef, $no_delete, $mode_or, $mode_and, $no_symlink);
  205.         }
  206.  
  207.         &change_mode ($mode, $dest);
  208.  
  209.     } else {
  210.         local (@stat)        = stat (_);        # stat done above for -d/-l
  211.         local ($file_bufsize)    = ($stat[$main'ST_BLKSIZE] > $bufsize) ? $stat[$main'ST_BLKSIZE] : $bufsize;
  212.         local ($dest_fix)    = &fix_file ($dest, '>', $package);
  213.         local ($src_fix)    = &fix_file ($src,  '<', $package);
  214.         local ($len)        = undef;
  215.         local ($buf)        = "\0" x $file_bufsize;
  216.  
  217.         if (! defined ($mode)) {
  218.             local ($dev, $inode);
  219.  
  220.             ($dev, $inode, $mode) = stat (_);
  221.             $mode &= 07777;
  222.         }
  223.  
  224.         $mode |= $mode_or                if (defined ($mode_or));
  225.         $mode &= $mode_and                if (defined ($mode_and));
  226.  
  227.         open (INP, $src_fix)                || die "$prog: open $src: $!\n";
  228.         open (OUT, $dest_fix)                || die "$prog: open $dest: $!\n";
  229.  
  230.         &trace (sprintf ("copy [mode 0%03o] %s %s%s",
  231.                  $mode, $src, $dest,
  232.                  (($no_delete) ? ', no delete' : '')))    if ($trace_p);
  233.  
  234.         while ($len = sysread (INP, $buf, $file_bufsize)) {
  235.             if (! defined ($len)) {
  236.                 next                if ($! =~ /^Interrupted/);
  237.                 die "$prog: read error: $!\n";
  238.             }
  239.  
  240.             $offset = 0;
  241.             while ($len) {
  242.                 $written = syswrite (OUT, $buf, $len, $offset);
  243.                 die "$prog: write error: $!\n"    unless defined ($written);
  244.  
  245.                 $len -= $written;
  246.                 $offset += $written;
  247.             }
  248.         }
  249.     
  250.         close (INP);
  251.         close (OUT);
  252.  
  253.         &change_mode ($mode, $dest);
  254.     }
  255. }
  256.  
  257.  
  258. # Function to compare two files, returning 0 if they are equal, != 0 otherwise.
  259. # Argument 1 is a file to compare.
  260. # Argument 2 is a file to compare.
  261. # Argument 3 is an optional timestamp to assume the files are equal if both older than it
  262.  
  263. # Taken from dcmp, but hacked upon since then.
  264.  
  265. sub compare_files {
  266.     local ($nargs)            = scalar (@_);
  267.     die "$prog: compare_files called with $nargs arguments.\n" if ($nargs < 2 || $nargs > 3);
  268.  
  269.     local ($package, $src, $line)    = caller;
  270.     local ($file_a)            = &fix_file (shift (@_), '', $package);
  271.     local ($file_b)            = &fix_file (shift (@_), '', $package);
  272.     local ($last_change_time)    = shift (@_);
  273.     local ($ret)            = 0;
  274.     local ($done)            = 0;
  275.     local ($len_a, $len_b);
  276.     local ($buf_a, $buf_b);
  277.     local (@stat_a);
  278.     local (@stat_b);
  279.     local ($len_a);
  280.     local ($len_b);
  281.     local ($bufsize_a);
  282.     local ($bufsize_b);
  283.     local ($file_bufsize);
  284.  
  285.     &trace ('compare', $file_a, $file_b)            if ($trace_p);
  286.  
  287.  
  288.     if (! (@stat_a = stat ($file_a))) {
  289.         $ret = 2;
  290.         $done = 1;
  291.         &trace ("stat error: $file_a: $!")        if ($trace_p);
  292.  
  293.     } elsif (! (@stat_b = stat ($file_b))) {
  294.         $ret = 2;
  295.         $done = 1;
  296.         &trace ("stat error: $file_b: $!")        if ($trace_p);
  297.     }
  298.  
  299.     $len_a = $stat_a[ $[ + $main'ST_SIZE];
  300.     $len_b = $stat_b[ $[ + $main'ST_SIZE];
  301.  
  302.     # Don't bother actually reading the file if we know it isn't equal
  303.     if ($done) {                        # error above in doing stats
  304.  
  305.     } elsif ($len_a != $len_b) {                # files have different lengths
  306.         $ret = 1;
  307.         $done = 1;
  308.  
  309.     } elsif ($len_a == 0) {                    # zero length files
  310.         $ret = 0;
  311.         $done = 1;
  312.  
  313.     } elsif (defined ($last_change_time) && $last_change_time
  314.          && $stat_a[$ST_MTIME] < $last_change_time
  315.          && $stat_b[$ST_MTIME] < $last_change_time) {    # files modified before some time delta
  316.  
  317.         $ret = 0;
  318.         $done = 1;
  319.     }
  320.  
  321.  
  322.     if (! $done) {
  323.         $bufsize_a = ($stat_a[$main'ST_BLKSIZE] > $bufsize) ? $stat[$main'ST_BLKSIZE] : $bufsize;
  324.         $bufsize_b = ($stat_b[$main'ST_BLKSIZE] > $bufsize) ? $stat[$main'ST_BLKSIZE] : $bufsize;
  325.         $file_bufsize = ($bufsize_a > $bufsize_b) ? $bufsize_a : $bufsize_b;
  326.  
  327.         $buf_a = "\0" x $file_bufsize;
  328.         $buf_b = "\0" x $file_bufsize;
  329.  
  330.         open (FILE_A, $file_a)                || die "$prog: open $file_a: $!\n";
  331.         open (FILE_B, $file_b)                || die "$prog: open $file_b: $!\n";
  332.  
  333.         while (! $done) {
  334.             $len_a = sysread (FILE_A, $buf_a, $file_bufsize);
  335.  
  336.             if (! defined ($len_a)) {
  337.                 next                if ($! =~ /^Interrupted/);
  338.                 die "$prog: read error on $file_a: $!\n";
  339.             }
  340.  
  341.             while () {
  342.                 $len_b = sysread (FILE_B, $buf_b, $file_bufsize);
  343.                 last                if (defined ($len_b));
  344.                 next                if ($! =~ /^Interrupted/);
  345.                 die "$prog: read error on $file_b: $!\n";
  346.             }
  347.  
  348.             last                    if ($len_a == 0 && $len_b == 0);
  349.             next                    if ($len_a == $len_b && $buf_a eq $buf_b);
  350.  
  351.             $ret = 1;
  352.             $done = 1;
  353.         }
  354.     }
  355.  
  356.     &trace (($ret) ? 'files are not equal.' : 'files are equal.')    if ($trace_p);
  357.     $ret;
  358. }
  359.  
  360.  
  361. # Make sure require does not abort
  362. 1;
  363.