#+##############################################################################
#                                                                              #
# File: Utils.pm                                                               #
#                                                                              #
# Description: general-purpose, bullet-proof(?) utilities                      #
#                                                                              #
#-##############################################################################

# $Id: Utils.pm,v 1.27 2000/11/17 12:14:59 cons Exp $

package Utils;

use strict;
use POSIX qw(:errno_h :sys_wait_h); # we need a few POSIX constants

BEGIN {
    require 5.003;
    use Exporter ();
    use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION);
    @ISA = qw(Exporter);
    @EXPORT = qw();
    @EXPORT_OK = (
		  'ask',	# ask something to the user
		  'contents',	# get or set a file or directory contents
		  'copy',	# copy a file
		  'destroy',	# destroy a file or directory
		  'differ',	# check if two files are different
		  'evaluate',   # eval() some code or a file, maybe being strict
		  'fchecksum',	# 32-bit file checksum
		  'mail',	# send a mail using sendmail
		  'makedir',	# make a directory
		  'move',	# move a file
		  'rectrl',     # inverse of unctrl: x eq rectrl(unctrl(x))
		  'remove',	# remove a file, handling busy files
		  'rglob',	# restricted file globing
		  'schecksum',	# 32-bit string checksum
		  'shuffle',	# shuffle a given list
		  'timestamp',	# sortable string representation of a date
		  'unctrl',	# eval'able version of a string
		  'which',	# return the path of a command
		  );
    $VERSION = sprintf("%d.%02d", q$Revision: 1.27 $ =~ /(\d+)\.(\d+)/);
}

# external variables
use vars qw($error);
$error = "";			# last error message generated by this module

# internal variables used for caching
use vars qw(%unctrl %rectrl);

# internal constant for Utils::contents, Utils::copy and such
sub SYSBUFSIZE () { 8192 }

# prototypes (forward declarations)
sub copy ($$;$);
sub destroy ($);
sub makedir ($;$);
sub remove ($);
sub schecksum ($);

#+++############################################################################
#                                                                              #
# read a file or directory contents or write to a file                         #
#                                                                              #
#---############################################################################

sub contents ($;$) {
    my($path, $contents) = @_;
    my(@contents, $length, $offset, $done);
    local(*HANDLE);

    $error = "";
    if (defined($contents)) {
	# write
	Utils::remove($path) or return(0);
	unless (open(HANDLE, "> $path")) {
	    $error = "open(>$path): $!";
	    return(0);
	}
	binmode(HANDLE);
	$length = length($contents);
        $offset = 0;
        while ($length) {
            $done = syswrite(HANDLE, $contents, SYSBUFSIZE, $offset);
            unless (defined($done)) {
		$error = "syswrite($path): $!";
		return(0);
	    }
            $length -= $done;
            $offset += $done;
        }
	unless (close(HANDLE)) {
	    $error = "close($path): $!";
	    return(0);
	}
	return(1);
    }
    # read
    unless (-e $path) {
	$error = "no such file or directory";
	return();
    }
    if (-f _) {
	# read a file
	unless (open(HANDLE, $path)) {
	    $error = "open($path): $!";
	    return();
	}
	binmode(HANDLE);
	$contents = "";
	while (1) {
	    $done = sysread(HANDLE, $contents, SYSBUFSIZE, length($contents));
	    unless (defined($done)) {
		$error = "sysread($path): $!";
		return();
	    }
	    last unless $done;
	}
	unless (close(HANDLE)) {
	    $error = "close($path): $!";
	    return();
	}
	return($contents);
    } elsif (-d _) {
	# read a directory
	unless (opendir(HANDLE, $path)) {
	    $error = "opendir($path): $!";
	    return();
	}
	@contents = grep($_ !~ /^\.\.?$/, readdir(HANDLE));
	unless (closedir(HANDLE)) {
	    $error = "closedir($path): $!";
	    return();
	}
	return(@contents);
    } else {
	$error = "not a file or a directory";
	return();
    }
}

#
# restricted version of Perl's glob():
#  - does not fork any shell
#  - does not trigger automounters
# but
#  - handles only * as full directory wildcard
#  - doesn't follow symbolic links
#
sub rglob ($) {
    my($pattern) = @_;
    my($before, $after, @list, $name, @result);

    $error = "";
    # check the pattern
    unless ($pattern =~ /^(.*)\*(.*)$/) {
	$error = "invalid pattern (no *): $pattern";
	return();
    }
    ($before, $after) = ($1, $2);
    if ($before =~ /\*/ or $after =~ /\*/) {
	$error = "invalid pattern (too many *): $pattern";
	return();
    }
    if (length($before) and $before !~ /\/$/) {
	$error = "invalid pattern (no dir before *): $pattern";
	return();
    }
    if (length($after) and $after !~ /^\//) {
	$error = "invalid pattern (no dir after *): $pattern";
	return();
    }
    # read the directory
    if ($before) {
	# it's not an error if the directory doesn't exist
	return() unless -d $before;
	@list = contents($before);
    } else {
	@list = contents(".");
    }
    return() if $error; # oops, error while reading directory...
    # check directory contents
    @result = ();
    foreach $name (@list) {
	# skip files starting with a dot
	next if $name =~ /^\./;
	# skip symbolic links
	next if -l "$before$name";
	# test if what is after the * matches
	next if $after and not -e "$before$name$after";
	# ok for this one
	push(@result, "$before$name$after");
    }
    return(@result);
}

#+++############################################################################
#                                                                              #
# home-made and not very crypto-strong 32-bit checksum                         #
#                                                                              #
#---############################################################################

#
# file contents checksum
#
sub fchecksum ($;$) {
    my($path, $length) = @_;
    local(*DATA);
    my(@stat, $sum, $buf, $bufsize, $done);

    $error = "";
    # open the file
    unless (open(DATA, $path)) {
	$error = "open($path): $!";
	return();
    }
    binmode(DATA);
    # find its size
    unless (defined($length)) {
	@stat = stat($path);
	unless (@stat) {
	    $error = "stat($path): $!";
	    return();
	}
	$length = $stat[7];
    }
    # special handling for small files
    if ($length < 1024) {
	$buf = "";
	while (1) {
	    $done = sysread(DATA, $buf, SYSBUFSIZE, length($buf));
	    unless (defined($done)) {
		$error = "sysread($path): $!";
		return();
	    }
	    last unless $done;
	}
	$sum = Utils::schecksum($buf);
    } else {
	$bufsize = $length < 16384 ? 256 : 4096;
	$sum = 0;
	while (1) {
	    $done = sysread(DATA, $buf, $bufsize);
	    unless (defined($done)) {
		$error = "sysread($path): $!";
		return();
	    }
	    last if $done == 0;
	    $sum = (($sum & 0x0000001F) << 27) ^ # 5 lower bits put on the left
		   ($sum >> 5)                 ^ # rest shifted right
		   unpack("%32C*", $buf);        # use byte sum of $buf
	}
    }
    # that's it!
    unless (close(DATA)) {
	$error = "close($path): $!";
	return();
    }
    return($sum);
}

#
# string checksum
#
sub schecksum ($) {
    my($string) = @_;
    my($sum);

    $sum = 0;
    while (length($string) > 3) {
	$sum = (($sum & 0x0000001F) << 27) ^ # 5 lower bits put on the left
	       ($sum >> 5)                 ^ # rest shifted right
	       unpack("N", $string);         # use first 4 bytes of $string
	substr($string, 0, 4) = "";
    }
    if (length($string)) {
	$sum = (($sum & 0x0000001F) << 27) ^
	       ($sum >> 5)                 ^
	       unpack("N", $string . "\0\0\0");
    }
    return($sum);
}

#+++############################################################################
#                                                                              #
# copy and move                                                                #
#                                                                              #
#---############################################################################

#
# copy a file, optionaly preserving owner, mode and time
# (this is loosely based on the Camel's syswrite)
# warning: in case of error (even with chmod()), the target file is removed!
#
sub copy ($$;$) {
    my($from, $to, $preserve) = @_;
    my(@stat, $buffer, $length, $done, $offset);
    local(*FROM, *TO);

    # init
    $error = "";
    unless (@stat = stat($from)) {
	$error = "stat($from): $!";
	return(0);
    }
    unless (open(FROM, $from)) {
	$error = "open($from): $!";
	return(0);
    }
    binmode(FROM);
    Utils::remove($to) or return(0);
    unless (open(TO, "> $to")) {
	$error = "open(>$to): $!";
	goto GOT_ERROR;
    }
    binmode(TO);
    # copy
    $buffer = ""; # to please perl -w
    while (1) {
	$length = sysread(FROM, $buffer, SYSBUFSIZE);
        unless (defined($length)) {
	    $error = "sysread($from): $!";
	    goto GOT_ERROR;
	}
	last unless $length;
        $offset = 0;
        while ($length) {
            $done = syswrite(TO, $buffer, $length, $offset);
            unless (defined($done)) {
		$error = "syswrite($to): $!";
		goto GOT_ERROR;
	    }
            $length -= $done;
            $offset += $done;
        }
    }
    # close
    unless (close(TO)) {
	$error = "close($to): $!";
	goto GOT_ERROR;
    }
    unless (close(FROM)) {
	$error = "close($from): $!";
	goto GOT_ERROR;
    }
    return(1) unless $preserve;
    # now trying to copy mode, time and owner
    $stat[2] &= 07777;
    unless (chmod($stat[2], $to)) {
	$error = sprintf("chmod(%04o, %s): %s", $stat[2], $to, $!);
	return(0);
    }
    unless (utime($stat[8], $stat[9], $to)) {
	$error = "utime($stat[8], $stat[9], $to): $!";
	goto GOT_ERROR;
    }
    unless (chown($stat[4], $stat[5], $to)) {
	$error = "chown($stat[4], $stat[5], $to): $!";
	goto GOT_ERROR;
    }
    # success
    return(1);
    # failure
  GOT_ERROR:
    unlink($to);
    return(0);
}

#
# move a file, following the /bin/mv algorithm
# (except that the second argument can't be a directory)
#
sub move ($$) {
    my($from, $to) = @_;

    # init
    $error = "";
    # we first try to rename the file
    rename($from, $to) and return(1);
    # did it fail because of a cross-device link?
    unless ($! == EXDEV) {
	$error = "rename($from, $to): $!";
	return(0);
    }
    # we now try to copy and preserve mode, owner...
    unless (Utils::copy($from, $to, 1)) {
	$error = "Utils::copy($from, $to, 1): $error";
	return(0);
    }
    # we finally remove the source
    unless (unlink($from)) {
	$error = "unlink($from): $!";
	# since this failed, we also remove the copy!
	unlink($to);
	return(0);
    }
    # succes
    return(1);
}

#+++############################################################################
#                                                                              #
# remove a file (not a directory) with unlink() and maybe rename()             #
#                                                                              #
#---############################################################################

sub remove ($) {
    my($path) = @_;

    $error = "";
    lstat($path); # don't follow symlinks!
    return(1) unless -e _;
    if (-d _) {
	$error = "can't remove a directory";
	return(0);
    }
    # we first try to unlink the file
    unlink($path) and return(1);
    # did it fail because of a text file busy error?
    unless ($! == ETXTBSY) {
	$error = "unlink($path): $!";
	return(0);
    }
    # we now try to rename the file
    my $busy;
    if ($path =~ /^.*\//) {
	$busy = $& . "#" . $';
    } else {
	$busy = "#" . $path;
    }
    unless (rename($path, $busy)) {
	$error = "rename($path, $busy): $!";
	return(0);
    }
    return(1);
}

#+++############################################################################
#                                                                              #
# destroy everything under a given path a la 'rm -fr'                          #
# (busy files will create problems as they will prevent directory removal)     #
#                                                                              #
#---############################################################################

sub destroy ($) {
    my($path) = @_;

    $error = "";
    lstat($path); # don't follow symlinks!
    return(1) unless -e _;
    if (-d _) {
	# directory
	my($name);
	local(*DIR);
        unless (opendir(DIR, $path)) {
            $error = "opendir($path): $!";
            return(0);
        }
	# destroy the directory contents
        while (defined($name = readdir(DIR))) {
            next if $name =~ /^\.\.?$/;
	    return(0) unless Utils::destroy("$path/$name");
        }
	unless (closedir(DIR)) {
            $error = "closedir($path): $!";
            return(0);
	}
	# remove the empty directory
	unless (rmdir($path)) {
	    $error = "rmdir($path): $!";
	    return(0);
	}
    } else {
	# not a directory
	unless (unlink($path)) {
	    $error = "unlink($path): $!";
	    return(0);
	}
    }
    return(1);
}

#+++############################################################################
#                                                                              #
# check if two plain files differ (byte comparison of the contents)            #
#                                                                              #
# warning: the files are found different is sysread() does not return          #
# the same length for both files; is it a bug?                                 #
#                                                                              #
#---############################################################################

sub differ ($$) {
    my($path1, $path2) = @_;
    my($result, $done1, $done2, $data1, $data2);
    local(*FILE1, *FILE2);
    
    # init
    $error = "";
    unless (open(FILE1, $path1)) {
	$error = "open($path1): $!";
	return();
    }
    binmode(FILE1);
    unless (open(FILE2, $path2)) {
	$error = "open($path2): $!";
	return();
    }
    binmode(FILE2);
    $result = undef;
    $data1 = $data2 = "";
    while (1) {
	$done1 = sysread(FILE1, $data1, SYSBUFSIZE);
	unless (defined($done1)) {
	    $error = "sysread($path1): $!";
	    last;
	}
	$done2 = sysread(FILE2, $data2, SYSBUFSIZE);
	unless (defined($done2)) {
	    $error = "sysread($path2): $!";
	    last;
	}
	$result = 1, last if $done1 != $done2;
	$result = 0, last if $done1 == 0;
	$result = 1, last if $data1 ne $data2;
    }
    unless (close(FILE1)) {
	$error = "close($path1): $!";
	return();
    }
    unless (close(FILE2)) {
	$error = "close($path2): $!";
	return();
    }
    return($result);
}

#+++############################################################################
#                                                                              #
# eval() some code or a file, maybe being strict                               #
#                                                                              #
#---############################################################################

sub evaluate ($;$$) {
    my($path, $code, $strict) = @_;
    my($warnings, $package, $wantarray, $return, @return);

    $error = "";
    # get code to eval
    unless (defined($code)) {
	$code = contents($path);
	if ($error) {
	    $error = "contents($path): $error";
	    return();
	}
    }
    # make sure that the path is meaningful
    unless (defined($path)) {
	my($package, $filename, $line) = caller;
	$path = "[$filename:$line]";
    }
    # eval the code
    $wantarray = wantarray;
    ($package) = caller;
    $code = "package $package;\n#line 1 \"$path\"\n" . $code;
    if ($strict) {
	$warnings = "";
	local $SIG{'__WARN__'} = sub { $warnings .= $_[0] };
	local $^W = 1;
	$code = "use strict;\n" . $code;
	if ($wantarray) {
	    @return = eval($code);
	} elsif (defined($wantarray)) {
	    $return = eval($code);
	} else {
	    eval($code);
	}
    } else {
	$code = "no strict;\n" . $code;
	if ($wantarray) {
	    @return = eval($code);
	} elsif (defined($wantarray)) {
	    $return = eval($code);
	} else {
	    eval($code);
	}
    }
    # check the errors
    if ($strict) {
	$error = $warnings;
	$error .= $@ if $@;
    } else {
	$error = $@;
    }
    # return the result anyway
    if ($wantarray) {
	return(@return);
    } elsif (defined($wantarray)) {
	return($return);
    } else {
	return();
    }
}

#+++############################################################################
#                                                                              #
# send a mail somewhere using sendmail                                         #
#                                                                              #
#---############################################################################

sub mail ($;$$) {
    my($to, $subject, $contents) = @_;
    my($sendmail, $pid);
    local(*MAIL);

    # init
    $error = "";
    unless ($to) {
	$error = "unknown destination";
	return(0);
    }
    $subject  = "<none>"    unless defined($subject);
    $contents = "<nothing>" unless defined($contents);
    $sendmail = "/usr/lib/sendmail";
    $sendmail = "/usr/sbin/sendmail" unless -x $sendmail;
    unless (-x $sendmail) {
	$error = "sendmail not found";
	return(0);
    }
    # compose and send
    $pid = open(MAIL, "|-");
    unless (defined($pid)) {
	$error = "open(|-): $!";
	return(0);
    }
    unless ($pid) {
	exec($sendmail, "-oi", $to);
	# we can die here as this is the child...
	die "exec($sendmail): $!";
    }
    print MAIL <<EOM;
To: $to
Subject: $subject
Precedence: junk

$contents
EOM
    close(MAIL);
    if ($? >> 8) {
	$error = sprintf("%s exited with %X", $sendmail, $?);
	return(0);
    }
    return(1);
}

#+++############################################################################
#                                                                              #
# recursively make directories with mode 0755 by default                       #
#                                                                              #
#---############################################################################

sub makedir ($;$) {
    my($dir, $mode) = @_;

    $error = "";
    unless (-d $dir) {
	$mode = 0755 unless defined($mode);
        if ($dir =~ m#(.+)/.*#) {
            Utils::makedir($1, $mode) or return(0);
        }
        unless (mkdir($dir, $mode)) {
	    $error = sprintf("mkdir(%s, %04o): %s", $dir, $mode, $!);
            return(0);
        }
    }
    return(1);
}

#+++############################################################################
#                                                                              #
# return the given list in random order                                        #
#                                                                              #
#---############################################################################

sub shuffle (@) {
    my(@in) = @_;
    my($idx, @out);

    while (@in) {
        $idx = int(rand(scalar(@in)));
        push(@out, splice(@in, $idx, 1));
    }
    return(@out);
}

#+++############################################################################
#                                                                              #
# timestamp with a nice compact (but Y2K safe) format: 1998/06/22-16:34:11     #
# the result is of fixed length and can be lexically sorted                    #
#                                                                              #
#---############################################################################

sub timestamp ($) {
    my($time) = @_;
    my($sec, $min, $hour, $mday, $mon, $year);
    
    # special case if time is -1 (usually an error)
    return("????/??/??-??:??:??") if $time == 0xFFFFFFFF;
    # normal case, we assume that we want local time
    ($sec, $min, $hour, $mday, $mon, $year) = localtime($time);
    return(sprintf("%04d/%02d/%02d-%02d:%02d:%02d",
                   $year+1900, $mon+1, $mday, $hour, $min, $sec));
}

#+++############################################################################
#                                                                              #
# escape control characters so that the string can be safely printed           #
# also, the result can be eval'ed by Perl inside a double quoted string        #
# (rectrl will give you back the original string if you're afraid of eval ;-)  #
#                                                                              #
#---############################################################################

sub _ctrl_init () {
    my($code, $char);

    foreach $code (0..255) {
	$char = chr($code);
	if ($code < 32 and $code != 28) {
	    # control chars
	    $unctrl{$char} =
		'\c' . ('@', 'A' .. 'Z', '[', '\\', ']', '^', '_')[$code];
	} elsif ($code == 28) {
	    # special case for <fs> because \c\ is not very safe...
	    $unctrl{$char} = '\034';
	} elsif ($code == 127) {
	    # delete (another control char)
	    $unctrl{$char} = '\c?';
	} elsif ($code > 127) {
	    # other unprintable
	    $unctrl{$char} = sprintf('\%03o', $code);
	} else {
	    # printable
	    $unctrl{$char} = $char;
	}
    }
    # exceptions so that output is nicer
    $unctrl{"\t"} = '\t';
    $unctrl{"\n"} = '\n';
    $unctrl{"\r"} = '\r';
    $unctrl{"\f"} = '\f';
    $unctrl{"\b"} = '\b';
    $unctrl{"\a"} = '\a';
    $unctrl{"\e"} = '\e';
    # exceptions to prevent variable interpolation in eval
    $unctrl{"\$"} = '\$';
    $unctrl{"\@"} = '\@';
    # exceptions to prevent syntax errors in eval
    $unctrl{"\""} = '\"';
    $unctrl{"\\"} = '\\\\';
    # store also the inverse map
    %rectrl = reverse(%unctrl);
}

sub unctrl ($) {
    my($string) = @_;

    _ctrl_init() unless keys(%unctrl);
    $string =~ s/(.)/$unctrl{$1}/egs;
    return($string);
}

sub rectrl ($) {
    my($string) = @_;

    _ctrl_init() unless keys(%unctrl);
    $string =~
	s/(\\(?:[tnrfbae\$\@\"\\]|c[\@A-Z\[\]\^\_\?]|[0-7]{3}))/$rectrl{$1}/egs;
    return($string);
}

#+++############################################################################
#                                                                              #
# check if a command is available and return its path                          #
#                                                                              #
#---############################################################################

sub which ($;$) {
    my($name, $dirs) = @_;
    my($dir, $path);

    if ($name =~ /\//) {
	# already a path
	return($name) if -x $name;
    } else {
	# look for name in the given list of dirs or in $PATH
	$dirs = $ENV{"PATH"} unless defined($dirs);
	return() unless defined($dirs);
	foreach $dir (split(/:/, $dirs)) {
	    $dir = "." if $dir eq "";
	    $path = "$dir/$name";
	    return($path) if -x $path;
	}
    }
    return();
}

#+++############################################################################
#                                                                              #
# ask something to the user (if there is a terminal) handling defaults,        #
# continuation lines, acceptable answers regexp...                             #
#                                                                              #
#---############################################################################

sub ask ($;$$) {
    my($question, $answers, $default) = @_;
    my($answer, $line);

    return($default) unless -t STDIN and -t STDOUT;
    local $| = 1;
    do {
	print "$question? ";
	$answer = "";
	do {
	    $line = <STDIN>;
	    return() unless defined($line); # ^D
	    chomp($line);
	    $answer .= $line;
	} while ($answer =~ s/\\$/\n/);
	$answer = $default if defined($default) and !length($answer);
    } while (defined($answers) and $answer !~ /$answers/);
    return($answer);
}

1;