slack 1:0.15.2-9 / usr / lib / slack / Slack.pm

# $Id: Slack.pm 189 2008-04-21 00:52:56Z sundell $
# vim:sw=2
# vim600:fdm=marker
# Copyright (C) 2004-2008 Alan Sundell <alan@sundell.net>
# All Rights Reserved.  This program comes with ABSOLUTELY NO WARRANTY.
# See the file COPYING for details.

package Slack;

require 5.006;
use strict;
use Carp qw(cluck confess croak);
use File::Find;
use POSIX qw(WIFEXITED WEXITSTATUS WIFSIGNALED WTERMSIG);

use base qw(Exporter);
use vars qw($VERSION @EXPORT @EXPORT_OK $DEFAULT_CONFIG_FILE);
$VERSION = '0.15.2';
@EXPORT    = qw();
@EXPORT_OK = qw();

$DEFAULT_CONFIG_FILE = '/etc/slack.conf';

my $term;

my @default_options = (
    'help|h|?',
    'version',
    'verbose|v+',
    'quiet',
    'config|C=s',
    'source|s=s',
    'rsh|e=s',
    'cache|c=s',
    'stage|t=s',
    'root|r=s',
    'dry-run|n',
    'backup|b',
    'backup-dir=s',
    'hostname|H=s',
);

sub default_usage ($) {
  my ($synopsis) = @_;
  return <<EOF;
Usage: $synopsis

Options:
  -h, -?, --help
      Print this help message and exit.

  --version
      Print the version number and exit.

  -v, --verbose
      Be verbose.

  --quiet
      Don't be verbose (Overrides previous uses of --verbose)

  -C, --config  FILE
      Use this config file instead of '$DEFAULT_CONFIG_FILE'.

  -s, --source  DIR
      Source for slack files

  -e, --rsh  COMMAND
      Remote shell for rsync

  -c, --cache  DIR
      Local cache directory for slack files

  -t, --stage  DIR
      Local staging directory for slack files

  -r, --root  DIR
      Root destination for slack files

  -n, --dry-run
      Don't write any files to disk -- just report what would have been done.

  -b, --backup
      Make backups of existing files in ROOT that are overwritten.

  --backup-dir  DIR
      Put backups into this directory.

  -H, --hostname  HOST
      Pretend to be running on HOST, instead of the name given by
        gethostname(2).
EOF
}
# Read options from a config file.  Arguments:
#       file    => config file to read
#       opthash => hashref in which to store the options
#       verbose => whether to be verbose
sub read_config (%) {
  my %arg = @_;
  my ($config_fh);
  local $_;

  confess "Slack::read_config: no config file given"
    if not defined $arg{file};
  $arg{opthash} = {}
    if not defined $arg{opthash};

  open($config_fh, '<', $arg{file})
    or confess "Could not open config file '$arg{file}': $!";

  # Make this into a hash so we can quickly see if we're looking
  # for a particular option
  my %looking_for;
  if (ref $arg{options} eq 'ARRAY') {
    %looking_for = map { $_ => 1 } @{$arg{options}};
  }

  while(<$config_fh>) {
    chomp;
    s/#.*//; # delete comments
    s/\s+$//; # delete trailing spaces
    next if m/^$/; # skip empty lines

    if (m/^[A-Z_]+=\S+/) {
      my ($key, $value) = split(/=/, $_, 2);
      $key =~ tr/A-Z_/a-z-/;
      # Only set options we're looking for
      next if (%looking_for and not $looking_for{$key});
      # Don't set options that are already set
      next if defined $arg{opthash}->{$key};

      $arg{verbose} and print STDERR "Slack::read_config: Setting '$key' to '$value'\n";
      $arg{opthash}->{$key} = $value;
    } else {
      cluck "Slack::read_config: Garbage line '$_' in '$arg{file}' line $. ignored";
    }
  }

  close($config_fh)
    or confess "Slack::read_config: Could not close config file: $!";

  # The verbose option is treated specially in so many places that
  # we need to make sure it's defined.
  $arg{opthash}->{verbose} ||= 0;

  return $arg{opthash};
}

# Just get the exit code from a command that failed.
# croaks if anything weird happened.
sub get_system_exit (@) {
  my @command = @_;

  if (WIFEXITED($?)) {
    my $exit = WEXITSTATUS($?);
    return $exit if $exit;
  }
  if (WIFSIGNALED($?)) {
    my $sig = WTERMSIG($?);
    croak "'@command' caught sig $sig";
  }
  if ($!) {
    croak "Syserr on system '@command': $!";
  }
  croak "Unknown error on '@command'";
}

sub check_system_exit (@) {
  my @command = @_;
  my $exit = get_system_exit(@command);
  # Exit is non-zero if get_system_exit() didn't croak.
  croak "'@command' exited $exit";
}

# get options from the command line and the config file
# Arguments
#       opthash => hashref in which to store options
#       usage   => usage statement
#       required_options => arrayref of options to require -- an exception
#               will be thrown if these options are not defined
#       command_line_hash => store options specified on the command line here
sub get_options {
  my %arg = @_;
  use Getopt::Long;
  Getopt::Long::Configure('bundling');

  if (not defined $arg{opthash}) {
    $arg{opthash} = {};
  }

  if (not defined $arg{usage}) {
    $arg{usage} = default_usage($0);
  }

  my @extra_options = ();  # extra arguments to getoptions
  if (defined $arg{command_line_options}) {
    @extra_options = @{$arg{command_line_options}};
  }

  # Make a --quiet function that turns off verbosity
  $arg{opthash}->{quiet} = sub { $arg{opthash}->{verbose} = 0; };

  unless (GetOptions($arg{opthash},
                    @default_options,
                    @extra_options,
                    )) {
    print STDERR $arg{usage};
    exit 1;
  }
  if ($arg{opthash}->{help}) {
    print $arg{usage};
    exit 0;
  }

  if ($arg{opthash}->{version}) {
    print "slack version $VERSION\n";
    exit 0;
  }

  # Get rid of the quiet handler
  delete $arg{opthash}->{quiet};

  # If we've been given a hashref, save our options there at this
  # stage, so the caller can see what was passed on the command line.
  # Unfortunately, perl has no .replace function, so we iterate.
  if (ref $arg{command_line_hash} eq 'HASH') {
    while (my ($k, $v) = each %{$arg{opthash}}) {
      $arg{command_line_hash}->{$k} = $v;
    }
  }

  # Use the default config file
  if (not defined $arg{opthash}->{config}) {
    $arg{opthash}->{config} = $DEFAULT_CONFIG_FILE;
  }

  # We need to decide whether to be verbose about reading the config file
  # Currently we just do it if global verbosity > 2
  my $verbose_config = 0;
  if (defined $arg{opthash}->{verbose}
      and $arg{opthash}->{verbose} > 2) {
    $verbose_config = 1;
  }

  # Read options from the config file, passing along the options we've
  # gotten so far
  read_config(
      file => $arg{opthash}->{config},
      opthash => $arg{opthash},
      verbose => $verbose_config,
  );

  # The "verbose" option gets compared a lot and needs to be defined
  $arg{opthash}->{verbose} ||= 0;

  # The "hostname" option is set specially if it's not defined
  if (not defined $arg{opthash}->{hostname}) {
    use Sys::Hostname;
    $arg{opthash}->{hostname} = hostname;
  }

  # We can require some options to be set
  if (ref $arg{required_options} eq 'ARRAY') {
    for my $option (@{$arg{required_options}}) {
      if (not defined $arg{opthash}->{$option}) {
        croak "Required option '$option' not given on command line or specified in config file!\n";
      }
    }
  }

  return $arg{opthash};
}

sub prompt ($) {
  my ($prompt) = @_;
  if (not defined $term) {
    require Term::ReadLine;
    $term = new Term::ReadLine 'slack'
  }

  $term->readline($prompt);
}


# Calls the callback on absolute pathnames of files in the source directory,
# and also on names of directories that don't exist in the destination
# directory (i.e. where $source/foo exists but $destination/foo does not).
sub find_files_to_install ($$$) {
  my ($source, $destination, $callback) = @_;
  return find ({
      wanted => sub {
        if (-l or not -d _) {
          # Copy all files, links, etc
          my $file = $File::Find::name;
          &$callback($file);
        } elsif (-d _) {
          # For directories, we only want to copy it if it doesn't
          # exist in the destination yet.
          my $dir = $File::Find::name;
          # We know the root directory will exist (we make it above),
          # so skip the base of the source
          (my $short_source = $source) =~ s#/$##;
          return if $dir eq $short_source;

          # Strip the $source from the path,
          # so we can build the destination dir from it.
          my $subdir = $dir;
          ($subdir =~ s#^$source##)
            or croak "sub failed: $source|$subdir";

          if (not -d "$destination/$subdir") {
            &$callback($dir);
          }
        }
      }
    },
    $source,
  );
}

# Runs rsync with the necessary redirection to its filehandles
sub wrap_rsync (@) {
  my @command = @_;
  my ($pid);

  if ($pid = fork) {
    # Parent
  } elsif (defined $pid) {
    # Child
    open(STDIN, "<", "/dev/null")
      or die "Could not redirect STDIN from /dev/null\n";
    # This redirection is necessary because rsync sends
    #   verbose output to STDOUT
    open(STDOUT, ">&STDERR")
      or die "Could not redirect STDOUT to STDERR\n";
    exec(@command);
    die "Could not exec '@command': $!\n";
  } else {
    die "Could not fork: $!\n";
  }

  my $kid = waitpid($pid, 0);
  if ($kid != $pid) {
    die "waitpid returned $kid\n";
  } elsif ($?) {
    Slack::check_system_exit(@command);
  }
}

# Runs rsync with the necessary redirection to its filehandles, but also
# returns an FH to stdin and a PID.
sub wrap_rsync_fh (@) {
  my @command = @_;
  my ($fh, $pid);

  if ($pid = open($fh, "|-")) {
    # Parent
  } elsif (defined $pid) {
    # Child
    # This redirection is necessary because rsync sends
    #   verbose output to STDOUT
    open(STDOUT, ">&STDERR")
      or die "Could not redirect STDOUT to STDERR\n";
    exec(@command);
    die "Could not exec '@command': $!\n";
  } else {
    die "Could not fork: $!\n";
  }
  return($fh, $pid);
}

1;