Strip redundant Emacs mode markers from Perl scripts.

[distorted-backup] / snap.in

#! @PERL@
###
### Create and remove snapshots of block devices
###
### (c) 2011 Mark Wooding
###

###----- Licensing notice ---------------------------------------------------
###
### This program is free software; you can redistribute it and/or modify
### it under the terms of the GNU General Public License as published by
### the Free Software Foundation; either version 2 of the License, or
### (at your option) any later version.
###
### This program 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 should have received a copy of the GNU General Public License
### along with this program; if not, write to the Free Software Foundation,
### Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.

use Getopt::Long qw(:config gnu_compat bundling no_ignore_case);
use Text::ParseWords;

our $VERSION = "@VERSION@";

our %C = ( etc		=> "@sysconfdir@",
	   sbin		=> "@sbindir@",
	   snap		=> "@snaplibexecdir@" );

###--------------------------------------------------------------------------
### Utilities.

(our $QUIS = $0) =~ s:^.*/::;
sub whine ($) { my ($msg) = @_; print STDERR "$QUIS: $msg\n"; }
sub fail ($) { my ($msg) = @_; whine $msg; exit $! || ($? >> 8) || 255; }

###--------------------------------------------------------------------------
### Parse command line.

our $USAGE = "usage: $QUIS [-u] [-c FILE] DEVICE [KEY=VALUE ...]";
sub version { print "$QUIS, version $VERSION\n"; }
sub help {
  print <<EOF;
$USAGE

Options:
  -h, --help		Show this help text.
  -v, --version		Show the program version number.
  -c, --config=FILE	Use configuration FILE, not $CONF.
  -n, --no-act		Don't actually do anything; show what would be done.
  -u, --unsnap		Remove a snapshot taken earlier.
EOF
}

our $CONF = "$C{etc}/snaptab";
our $OP = "snap";
our $NOACT = 0;
GetOptions('help|h|?'		=> sub { version; help; exit; },
	   'version|v'		=> sub { version; exit; },
	   'config-file|c=s'	=> \$CONF,
	   'no-act|n'		=> \$NOACT,
	   'unsnap|u'		=> sub { $OP = "unsnap"; })
  and @ARGV >= 1
  or do { print STDERR $USAGE, "\n"; exit 1; };

our $DEV = shift;
our $TYPE = undef;

###--------------------------------------------------------------------------
### Parse the configuration file.

open CF, "<", $CONF or fail "open config ($CONF): $!";
our @KV = ();
our %DEF = ();
while (my $line = <CF>) {
  chomp $line;
  while ($line =~ /\\\s*$/) {
    chomp (my $more = <CF>);
    $line =~ s/\\\s*$/$more/;
  }
  next if $line =~ /^\s*(\#|$)/;
  my ($dev, $type, @opts) = shellwords $line;
  my @nopts = ();
  for my $i (@opts) {
    if ($i !~ /^\*\.(.+)$/) { push @nopts, $i; next; }
    my $ty = $1;
    for my $o (@{$DEF{$ty}}) {
      $o =~ /^([^=]+)=(.*)$/;
      my ($k, $v) = ($1, $2);
      ($k, $ty) = ($1, $2) if $k =~ /^(.+)\.([^.]+)/;
      push @nopts, "$k.$ty=$v";
    }
  }
  @opts = @nopts;
  if ($dev eq "*") { push @{$DEF{$type}}, @opts; }
  elsif ($dev eq $DEV) { push @KV, "type=$type", @{$DEF{$type}}, @opts; }
}
close CF or fail "close config ($CONF): $!";

###--------------------------------------------------------------------------
### Pick out the winning options.

our @OPT = ();
my $seen = ();

for my $i (reverse @KV, "op=$OP", @ARGV) {
  $i =~ /^([^=]+)=(.*)$/ or fail "malformed option `$i': missing `='";
  my ($k, $v) = ($1, $2);
  unless (exists $seen{$k}) {
    $seen{$k} = 1;
    if ($k eq "type") { $TYPE = $v; }
    else { push @OPT, "$k=$v"; }
  }
}

defined $TYPE or fail "no snapshot type for device `$DEV'";
@OPT = reverse @OPT;

###--------------------------------------------------------------------------
### Invoke the type-specific handler.

## Fix up the path, to make sure our tools are available.
my $path = $ENV{PATH};
my %path = map { $_ => 1 } split /:/, $path;
for my $p (qw( /bin /sbin /usr/bin /usr/sbin ), $C{sbin}) {
  $path = "$p:$path" unless exists $path{$p};
}
$ENV{PATH} = $path;

## Prepare the arguments.
my @args = ("$C{snap}/snap.$TYPE", $DEV, @OPT);

## Do the job.
if ($NOACT) {
  whine "run " . join(" ",
		      map { "`$_'" }
		      grep { s/'/\\'/g; 1 }
		      (my @x = @args));
} else {
  exec @args;
  fail "exec (snap.$TYPE): $!";
}

###----- That's all, folks --------------------------------------------------

exit 0;