# $Id: Utils.pm,v 1.22 2007/08/20 23:29:24 jbw Exp $

package JBW::Utils;

=head1 NAME

JBW::Utils - a few functions

=head1 SYNOPSIS

    use JBW::Utils qw(&get_file_contents &put_file_contents $backup_extension &with_file_contents &assert_successful_execution &system_checked &min &max);

    $stuff = get_file_contents('filename');

    put_file_contents('filename', 'new stuff');

    $backup_extension = '.backup';

    with_file_contents 'filename', sub {
        s/XXX/YYY/; };

    bind_to_files { 'filename1' => \$a, 'filename2' => \$b }, sub {
        $a =~ m/ABC(.*)XYZ/;
        $c = $1;
        $b =~ s/123/$c/; }

    assert_successful_execution (system ($command), $command);

    system_checked ($command);

    $min = min($val1, $val2, ...);

    $max = max($val1, $val2, ...);

=head1 DESCRIPTION

C<JBW::Utils> makes the below-described functions available.  None of
them are exported by default.

=over 4

=cut

# Set bits in $ to turn on extra compile-time and run-time checks.
use strict;

# Perform "require Exporter" at compile-time.
# "()" means Exporter's import method is _not_ invoked.
use Exporter ();

# Allow using these global package variables without including the
# package name.
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);

# Set the version for version checking (CVS method).
$VERSION = do { my @r = (q$Revision: 1.22 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; # must be all one line, for MakeMaker

# Cause method invocation to inherit from Exporter if method undefined
# here.  Makes these class methods available:
#   export, import, export_tags, export_ok_tags
@ISA         = qw(Exporter);

# We put these in a BEGIN block so they are available for the "use
# vars" statement which follows.
BEGIN {
    # affects the behavior of the "import" method inherited from Exporter.
    @EXPORT = qw(&get_file_contents
                 &put_file_contents
                 $backup_extension
                 &with_file_contents
                 &bind_to_files
                 &assert_successful_execution
                 &system_checked
                 &min
                 &max);

    # Optionally exported entities.
    @EXPORT_OK   = qw();
    
    #%EXPORT_TAGS = ( file => qw(&get_file_contents
    #                            &put_file_contents
    #                            &with_file_contents
    #                            &bind_to_files
    #                            &assert_successful_execution) );
    #(JBW::Utils)->export_ok_tags('file');
}

# allows using global package variables named in @EXPORT and
# @EXPORT_OK without including the package name. 
# also allows using functions named in @EXPORT and @EXPORT_OK as list
# operators without parentheses around the arguments. 
use vars @EXPORT, @EXPORT_OK;

# give Perl's magic variables readable names.
use English;

#BEGIN {
#    $_ = 'foo';
#    *ARG = *_;
#    *JBW::Utils::ARG = *_;
#}
#$_ = 'foo';
#print STDERR "ARG: [", $ARG, "]\n";
#print STDERR "main::ARG: [", $main::ARG, "]\n";
#print STDERR "JBW::Utils::ARG: [", $JBW::Utils::ARG, "]\n";
#die;

# Maybe reenable someday, once I no longer need to worry about old
# Perl versions.
#use IO::File;

use POSIX;

=item get_file_contents FILENAME

Returns the entire contents of the specified file as a string.

Dies if the file can not be opened for reading.

=cut

sub get_file_contents {
    my $file = shift;
    #print STDERR "get_file_contents file: [$file]\n";
    # ***TODO*** reenable once I am no longer depending on obsolete Perl
    #(my $fh = IO::File->new($file, '<')) || die "failed to open $file: $OS_ERROR";
    open (FILE, "<$file") || die "failed to open $file: $OS_ERROR";
    local $INPUT_RECORD_SEPARATOR = undef;
    # ***TODO*** reenable once I am no longer depending on obsolete Perl
    #my $file_contents = $fh->getline();
    # getline is implemented as "scalar <HANDLE>".  Can that return undef?
    #die "getline returned undef" if ! defined $file_contents;
    my $file_contents = <FILE>;
    die "file slurp returned undef for file: $file" if ! defined $file_contents;
    # Perl bug workaround.  Next line consumes special end-of-file
    # status waiting for the next reader.  This should be cleared
    # anyway by the close operation, but Perl seems to have a bug
    # regarding this.
    my $dummy = <FILE>;
    close (FILE);
    #print STDERR "file: [$file]\n";
    #system 'pwd';
    #print STDERR "file_contents: [$file_contents]\n";
    return $file_contents;

    ## **** will this really have the same effect as "undef $INPUT_RECORD_SEPARATOR"?
    #my $save = IO::File->input_record_separator(undef);
    #my $file_contents = $fh->getline();
    # **** how to unwind-protect setting of $INPUT_RECORD_SEPARATOR? ****
    #(IO::File)->input_record_separator($save);
    #return $file_contents;
}

=item put_file_contents FILENAME, NEW_CONTENTS

Stores in the file given by FILENAME the new contents given by the
string NEW_CONTENTS.  Overwrites an existing file or creates a new
file.

Dies if the file can not be opened for writing.

=cut

sub put_file_contents {
    my ($file, $file_contents) = @_;
    # ***TODO*** reenable once I am no longer depending on obsolete Perl
    #(my $fh = IO::File->new($file, '>')) || die "failed to open $file: $OS_ERROR";
    #$fh->print($file_contents);
    open (FILE, ">$file") || die "failed to open $file: $OS_ERROR";
    print FILE $file_contents;
    # ***TODO*** check return value of print!
    close (FILE);
}

=item put_file_contents_backup FILENAME, BACKUP_EXTENSION, NEW_CONTENTS

Stores in the file given by FILENAME the new contents given by the
string NEW_CONTENTS.  Overwrites an existing file or creates a new
file.  If BACKUP_EXTENSION is defined, makes a backup copy in a file
whose name is obtained from FILENAME by adding BACKUP_EXTENSION.  The
backup is made by renaming the old file and creating a new one in its
place.

Dies if the file can not be opened for writing or if the backup can
not be made.

=cut

sub put_file_contents_backup {
    my ($file, $backup_extension, $file_contents) = @_;
    # *** TODO: What to do when file does not already exist???
    if (defined $backup_extension) {
        if (! rename ($file, $file . $backup_extension)) {
            die "rename failed: $OS_ERROR"; }}
    put_file_contents ($file, $file_contents); }

=item with_file_contents FILENAME, sub BLOCK

Puts the contents of FILENAME in C<$_> (a.k.a. C<$ARG> if "use
English" is in effect), runs BLOCK, and replaces the contents of
FILENAME by the new value of C<$_> if it changed.  

Saves a backup copy of the old contents by first renaming the old file
to "FILENAME.$backup_extension" and writes the new string to a new
file by the same name, but only if $backup_extension is defined
(default ".bkp"); otherwise overwrites the old file with the new
string.

Returns whatever BLOCK returns.

Dies if the file can not be opened for reading and writing.

=cut

$backup_extension = '.bkp';

sub with_file_contents {
    my ($file, $sub) = @_;
    #print STDERR "entering with_file_contents\n";
    #print STDERR "file: [$file]\n";
    local $_ = get_file_contents($file);
    die "impossible" if ! defined $_;
    #print STDERR "_: [$_]\n";
    my $save = $_;
    my ($result, @result);
    #print STDERR "about to invoke sub\n";
    if (wantarray) {
        @result = &$sub(); }
    elsif (defined wantarray) {
        $result = &$sub(); }
    else {
        &$sub(); }
    #print STDERR "returned from sub\n";
    if ($_ ne $save) {
        #print STDERR "changed: $file\n";
        put_file_contents_backup ($file, $backup_extension, $_); }
    else {
        #print STDERR "kept same: $file\n";
    }
    if (wantarray) {
        return @result; }
    elsif (defined wantarray) {
        return $result; }}

=item bind_to_files HASHREF, sub BLOCK

The hash pointed to by HASHREF must map scalar references to file
names.  It is an error if any of the keys in the hash are not scalar
references or if any of the values are not strings or if any of the
values which are strings name files which exist but are not readable.

BLOCK will be executed while the scalar lvalues that are the keys of
the hash pointed to by HASHREF are associated with the contents of the
files.  For each scalar lvalue which is a key in HASHREF, when BLOCK
starts execution, the lvalue is set to the file contents if the
associated file exists and is otherwise set to undef.  The old values
of the scalar lvalues are restored after executing BLOCK.

Returns whatever BLOCK returns.  BLOCK will be executed in the
surrounding context.

When BLOCK is done, if a value for one of the lvalues started as a
string and is now a different string, then the corresponding file
FILENAME is updated with the new string.  Saves a backup copy of the
old contents by first renaming the old file to
"FILENAME.$backup_extension" and writes the new string to a new file
by the same name, but only if $backup_extension is defined (default
".bkp"); otherwise overwrites the old file with the new string.  If
the value started undefined and is now a string, the file is created.
If the value started as a string and is now undefined, the file is
deleted.  It is an error if the old file can not be renamed, if the
new file can not be created, or if the old file can not be deleted.

=cut

sub bind_to_files {
    my ($hashref, $sub) = @_;
    #print STDERR "entering bind_to_files\n";
    my $sref;
    my $file;
    my %old_value;
    my %initial_contents;
    my %sref;
    while (($file, $sref) = each %$hashref) {
        # **** verify key is a string (file name)
        # **** verify value is a scalar reference
        #print STDERR "[$$sref]\n";
        #print STDERR "A\n";
        $old_value{$file} = $$sref;
        #print STDERR "B\n";
        $$sref = undef;
        if (-f $file) {
            $$sref = get_file_contents($file); }
        else {
            #print STDERR "file doesn't exist: [$file]\n";
        }
        $initial_contents{$file} = $$sref;
        $sref{$file} = $sref; }
    my ($result, @result);
    #print STDERR "about to invoke sub\n";
    if (wantarray) {
        @result = &$sub(); }
    elsif (defined wantarray) {
        $result = &$sub(); }
    else {
        &$sub(); }
    #print STDERR "returned from sub\n";
    while (($file, $sref) = each %sref) {
        if (defined $$sref) {
            if (! (defined $initial_contents{$file})) {
                #print STDERR "new file: $file\n";
                put_file_contents ($file, $$sref); }
            elsif ($$sref ne $initial_contents{$file}) {
                #print STDERR "changed contents: $file\n";
                put_file_contents_backup ($file, $backup_extension, $$sref); }
            else {
                #print STDERR "kept same contents: $file\n";
            }}
        elsif (defined $initial_contents{$file}) {
            #print STDERR "file deleted: $file\n";
            (unlink $file) || die "unlink failed: $OS_ERROR"; }
        else {
            #print STDERR "file not created: $file\n";
        }
        $$sref = $old_value{$file}; }
    if (wantarray) {
        return @result; }
    elsif (defined wantarray) {
        return $result; }}

=item assert_successful_execution SYSTEM_RETURN_VALUE, COMMAND

Inspects SYSTEM_RETURN_VALUE (which should be the result of invoking
C<system>).  If SYSTEM_RETURN_VALUE indicates that the program did not
exit by invoking the system call C<exit(0)>, dies with an appropriate
error message mentioning COMMAND.

=cut

sub assert_successful_execution {
    my ($sys_ret_val, $command) = @_;
    if (POSIX::WIFEXITED($sys_ret_val)) {
        my $exit_status = POSIX::WEXITSTATUS($sys_ret_val);
        if ($exit_status) {
            die "'$command' exited with $exit_status\n"; }
    } else {
        if (POSIX::WIFSIGNALED($sys_ret_val)) {
            my ($signal) = POSIX::WTERMSIG($sys_ret_val);
            die "'$command' got signal $signal\n"; }
        else {
            die "'$command' died abnormally, but no signal!?!?!\n"; }}}

# *** TODO: copy code for checking the result of a `command` from my
# ~/bin/ssh script.  (The above assert_successful_execution is adapted
# from it, but omits the work needed to get the result obtained from
# the wait syscall in this case.)

=item system_checked COMMAND

Runs assert_successful_execution (system ($command), $command).

=cut

sub system_checked {
    my ($command) = @_;
    assert_successful_execution (system ($command), $command); }

=item min NUM1, NUM2, ...

If there is only 1 argument, returns NUM1.  If there are 2 arguments,
returns the smallest value (using the <= operator) of NUM1, NUM2, etc.
If there are no arguments, returns undef.

=cut

sub min {
    my $min;
    while (scalar(@_)) {
        if ((! defined $min) || $_[0] <= $min) {
            $min = $_[0]; }
        shift; }
    return $min; }

=item max NUM1, NUM2, ...

If there is only 1 argument, returns NUM1.  If there are 2 arguments,
returns the largest value (using the >= operator) of NUM1, NUM2, etc.
If there are no arguments, returns undef.

=cut

sub max {
    my $max;
    while (scalar(@_)) {
        if ((! defined $max) || $_[0] >= $max) {
            $max = $_[0]; }
        shift; }
    return $max; }

=back

# The return value of the file.
1;

=head1 VERSION

  $Id: Utils.pm,v 1.22 2007/08/20 23:29:24 jbw Exp $

=head1 AUTHOR

Joe Wells (F<http://www.macs.hw.ac.uk/~jbw>)

=head1 LICENSE

Copyright Joe Wells, 1999.

You can redistribute and/or modify this software under the terms of
the GNU General Public License as published by the Free Software
Foundation; either version 2, or (at your option) any later version.

This software is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
General Public License for more details.

You may obtain the GNU General Public License by writing to the Free
Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
02111-1307, USA.

=cut



# # Where bib2html is installed on local system.
# my ($Bib2HTMLDir) = "$HOME/bib2html-1.33";
# my ($Bib2HTMLProg) = "$Bib2HTMLDir/bib2html";
# 
# # RegenerateHTMLBib (HTML_BIB_FILE, AUX_FILE, BIB_NAME)
# #
# # (Re)generates an HTML formatted bibliography in a (possibly already
# # existing) HTML file.  The bibliography contains entries specified in
# # the file given by the AUX_FILE argument.
# #
# # Arguments:
# #
# #   HTML_BIB_FILE:   target HTML file, may already exist
# #   AUX_FILE:        source file, .aux output of LaTeX
# #   BIB_NAME:        name of a bib2html section in target file
# #
# sub RegenerateHTMLBib {
# 
#     my ($HTMLBibFile, $AuxFile, $BibName) = @_;
# 
#     # bib2html uses special style files.  However, it is too stupid to
#     # set the environment variable to tell bibtex this.  So we do it
#     # here.
# 
#     $ENV{'BSTINPUTS'} = $Bib2HTMLDir;
# 
#     # bib2html options:
#     #   -a         include abstracts
#     #   -c         chronological sorting
#     #   -r         reverse sorting order
#     #   -d XXX     use XXX as part of delimeter marker in HTML file
#     #   -t FILE    get \bibcite commands from FILE
#     #   -s STYLE   use STYLE list labels
#     #
#     # (Dis)Advantages of various values for STYLE:
#     #   empty:
#     #          bullet lists --- hard to see crossrefs visually.
#     #   plain: 
#     #          numbered list --- easy to see crossrefs visually, but
#     #          hard to read them directly.
#     #   alpha: 
#     #          labelled list with "KW94" style labels --- somewhat
#     #          easy to see crossrefs visually, can be read directly
#     #          somewhat easily, but ugly.
#     #   named: 
#     #          labelled list with "Kfoury and Wells, 1994" style
#     #          labels --- easy to see crossrefs visually, can be read
#     #          directly, fairly good looking, but sometimes omits
#     #          "Wells" due to author lists longer than 2 names.
#     #          Fixing requires hacking html-btxbst.doc, ugh.
#     
#     (system ("$Bib2HTMLProg -s plain -a -c -r -d $BibName "
#              . "-t $AuxFile $HTMLBibFile") == 0)
#         || die "system failed"; }


# #############################################
# # subroutines for playing with environments #
# #############################################
# 
# # For sanity checking.
# sub check_hash_defined_or_die {
#     my ($hashref) = @_;
#     my ($key);
#     foreach $key (keys %$hashref) {
#         #print "\$\$hashref{'$key'}: $$hashref{$key}\n";
#         if (! defined $$hashref{$key}) {
#             die "hash key $key has undefined value,"; }}}
# check_hash_defined_or_die (\%ENV);
# # Make shallow copy of %ENV.
# my (%orig_ENV) = %ENV;
# check_hash_defined_or_die (\%orig_ENV);
# #{
# #    my ($envvar);
# #    foreach $envvar (keys %orig_ENV) {
# #        print "\$orig_ENV{'$envvar'}: $orig_ENV{$envvar}\n"; }
# #}
# 
# sub quote_for_sh_or_csh {
#     my ($String) = @_;
#     $String =~ s/'/'\\''/;
#     if ($String =~ m/[^-+A-Za-z_0-9]/) {
#         $String = "'$String'"; }
#     return $String; }
# 
# sub print_modified_env_commands {
#     check_hash_defined_or_die (\%ENV);
#     my ($outputstyle) = (($ENV{'SHELL'} =~ m/csh$/) ? 'csh' : 'sh');
#     my ($VarName);
#     foreach $VarName (keys %ENV) {
#         # print "VarName: $VarName\n";
#         my ($VarNameQuoted) = quote_for_sh_or_csh ($VarName);
#         if ((! exists $orig_ENV{$VarName})
#             || ($ENV{$VarName} ne $orig_ENV{$VarName}))
#         {
#             my ($ValueQuoted) = quote_for_sh_or_csh ($ENV{$VarName});
#             if ($outputstyle eq 'sh') {
#                 # Note that this will produce code that will fail if
#                 # the variable name actually needs quotes.
#                 # Bourne-shell style shells appear not to have any way
#                 # to manipulate environment variables with funny
#                 # names. 
#                 print "$VarNameQuoted=$ValueQuoted ";
#                 print "export $VarNameQuoted;\n"; }
#             else {
#                 print "setenv $VarNameQuoted $ValueQuoted;\n"; }}}
#     foreach $VarName (keys %orig_ENV) {
#         my ($VarNameQuoted) = quote_for_sh_or_csh ($VarName);        
#         if (! exists $ENV{$VarName}) {
#             if ($outputstyle eq 'sh') {
#                 # Unimplemented.  In general, no way to delete an
#                 # environment variable for Bourne-shell style.
#                 # (Some specific shells have such commands, but we
#                 # don't want to make such small distinctions.)
#             }
#             else {
#                 print "unsetenv $VarNameQuoted;\n"; }}}}
# 
# ######################################################################
# 
# # crude hack, not always correct
# sub ContainingDir {
#     my ($File) = @_;
#     if ($File =~ m|^(.+)/[^/]+/*$|) {
#         return $1; }
#     elsif ($File =~ m|^/[^/]+/*$|) {
#         return '/'; }
#     else {
#         print "File: $File\n";
#         die "unhandled case"; }}
# 
# sub ChecksumFile {
#     my ($File) = @_;
#     if (open (FILE, $File)) {
#         my ($Checksum) = 0;
#         my ($Chunk) = 0;
#         my ($Result);
#         while (($Result = read (FILE, $Chunk, 8192)) != 0) {
#             $Checksum += unpack ("%16C*", $Chunk);
#             $Checksum %= 65536; }
#         if (! defined $Result) {
#             die "read on $File failed: $OS_ERROR"; }
#         if (! close (FILE)) {
#             die "close on $File failed: $OS_ERROR"; }
#         return $Checksum; }
#     else {
#         print STDERR "$PROGRAM_NAME: Can't open $File: $OS_ERROR\n";
#         return undef; }
# }