← Back to branch summary

~ubuntu-branches/ubuntu/hardy/slack/hardy-proposed

« back to all changes in this revision

Viewing changes to src/Slack.pm

  • Committer: Bazaar Package Importer
  • Author(s): Andrew Pollock
  • Date: 2007-10-27 16:14:42 UTC
  • Revision ID: james.westby@ubuntu.com-20071027161442-z3wjuy3juutuxu7m
Tags: upstream-0.14.1
Import upstream version 0.14.1

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/Slack.pm
 
1
# $Id: Slack.pm,v 1.9 2006/09/27 07:46:42 alan Exp $
 
2
# vim:sw=2
 
3
# vim600:fdm=marker
 
4
# Copyright (C) 2004-2006 Alan Sundell <alan@sundell.net>
 
5
# All Rights Reserved.  This program comes with ABSOLUTELY NO WARRANTY.
 
6
# See the file COPYING for details.
 
7
 
 
8
package Slack;
 
9
 
 
10
require 5.006;
 
11
use strict;
 
12
use Carp qw(cluck confess croak);
 
13
use File::Find;
 
14
 
 
15
use base qw(Exporter);
 
16
use vars qw($VERSION @EXPORT @EXPORT_OK $DEFAULT_CONFIG_FILE);
 
17
$VERSION = '0.1';
 
18
@EXPORT    = qw();
 
19
@EXPORT_OK = qw();
 
20
 
 
21
$DEFAULT_CONFIG_FILE = '/etc/slack.conf';
 
22
 
 
23
my $term;
 
24
 
 
25
my @default_options = (
 
26
    'help|h|?',
 
27
    'verbose|v+',
 
28
    'quiet',
 
29
    'config|C=s',
 
30
    'source|s=s',
 
31
    'cache|c=s',
 
32
    'stage|t=s',
 
33
    'root|r=s',
 
34
    'dry-run|n',
 
35
    'backup|b',
 
36
    'backup-dir=s',
 
37
    'hostname|H=s',
 
38
);
 
39
 
 
40
sub default_usage ($) {
 
41
  my ($synopsis) = @_;
 
42
  return <<EOF;
 
43
Usage: $synopsis
 
44
 
 
45
Options:
 
46
  -h, -?, --help
 
47
      Print this help message and exit.
 
48
 
 
49
  -v, --verbose
 
50
      Be verbose.
 
51
 
 
52
  --quiet
 
53
      Don't be verbose (Overrides previous uses of --verbose)
 
54
 
 
55
  -C, --config  FILE
 
56
      Use this config file instead of '$DEFAULT_CONFIG_FILE'.
 
57
 
 
58
  -s, --source  DIR
 
59
      Source for slack files
 
60
 
 
61
  -c, --cache  DIR
 
62
      Local cache directory for slack files
 
63
 
 
64
  -t, --stage  DIR
 
65
      Local staging directory for slack files
 
66
 
 
67
  -r, --root  DIR
 
68
      Root destination for slack files
 
69
 
 
70
  -n, --dry-run
 
71
      Don't write any files to disk -- just report what would have been done.
 
72
 
 
73
  -b, --backup
 
74
      Make backups of existing files in ROOT that are overwritten.
 
75
 
 
76
  --backup-dir  DIR
 
77
      Put backups into this directory.
 
78
 
 
79
  -H, --hostname  HOST
 
80
      Pretend to be running on HOST, instead of the name given by
 
81
        gethostname(2).
 
82
EOF
 
83
}
 
84
# Read options from a config file.  Arguments:
 
85
#       file    => config file to read
 
86
#       opthash => hashref in which to store the options
 
87
#       verbose => whether to be verbose
 
88
sub read_config (%) {
 
89
  my %arg = @_;
 
90
  my ($config_fh);
 
91
  local $_;
 
92
 
 
93
  confess "Slack::read_config: no config file given"
 
94
    if not defined $arg{file};
 
95
  $arg{opthash} = {}
 
96
    if not defined $arg{opthash};
 
97
 
 
98
  open($config_fh, '<', $arg{file})
 
99
    or confess "Could not open config file '$arg{file}': $!";
 
100
 
 
101
  # Make this into a hash so we can quickly see if we're looking
 
102
  # for a particular option
 
103
  my %looking_for;
 
104
  if (ref $arg{options} eq 'ARRAY') {
 
105
    %looking_for = map { $_ => 1 } @{$arg{options}};
 
106
  }
 
107
 
 
108
  while(<$config_fh>) {
 
109
    chomp;
 
110
    s/#.*//; # delete comments
 
111
    s/\s+$//; # delete trailing spaces
 
112
    next if m/^$/; # skip empty lines
 
113
 
 
114
    if (m/^[A-Z_]+=\S+/) {
 
115
      my ($key, $value) = split(/=/, $_, 2);
 
116
      $key =~ tr/A-Z_/a-z-/;
 
117
      # Only set options we're looking for
 
118
      next if (%looking_for and not $looking_for{$key});
 
119
      # Don't set options that are already set
 
120
      next if defined $arg{opthash}->{$key};
 
121
 
 
122
      $arg{verbose} and print STDERR "Slack::read_config: Setting '$key' to '$value'\n";
 
123
      $arg{opthash}->{$key} = $value;
 
124
    } else {
 
125
      cluck "Slack::read_config: Garbage line '$_' in '$arg{file}' line $. ignored";
 
126
    }
 
127
  }
 
128
 
 
129
  close($config_fh)
 
130
    or confess "Slack::read_config: Could not close config file: $!";
 
131
 
 
132
  # The verbose option is treated specially in so many places that
 
133
  # we need to make sure it's defined.
 
134
  $arg{opthash}->{verbose} ||= 0;
 
135
 
 
136
  return $arg{opthash};
 
137
}
 
138
 
 
139
# Just get the exit code from a command that failed.
 
140
# croaks if anything weird happened.
 
141
sub get_system_exit (@) {
 
142
  my @command = @_;
 
143
  if ($? & 128) {
 
144
    croak "'@command' dumped core";
 
145
  }
 
146
  if (my $sig = $? & 127) {
 
147
    croak "'@command' caught sig $sig";
 
148
  }
 
149
  my $exit = $? >> 8;
 
150
  return $exit if $exit;
 
151
  if ($!) {
 
152
    croak "Syserr on system '@command': $!";
 
153
  }
 
154
  croak "Unknown error on '@command'";
 
155
}
 
156
 
 
157
sub check_system_exit (@) {
 
158
  my @command = @_;
 
159
  my $exit = get_system_exit(@command);
 
160
  # Exit is non-zero if get_system_exit() didn't croak.
 
161
  croak "'@command' exited $exit";
 
162
}
 
163
 
 
164
# get options from the command line and the config file
 
165
# Arguments
 
166
#       opthash => hashref in which to store options
 
167
#       usage   => usage statement
 
168
#       required_options => arrayref of options to require -- an exception
 
169
#               will be thrown if these options are not defined
 
170
#       command_line_hash => store options specified on the command line here
 
171
sub get_options {
 
172
  my %arg = @_;
 
173
  use Getopt::Long;
 
174
  Getopt::Long::Configure('bundling');
 
175
 
 
176
  if (not defined $arg{opthash}) {
 
177
    $arg{opthash} = {};
 
178
  }
 
179
 
 
180
  if (not defined $arg{usage}) {
 
181
    $arg{usage} = default_usage($0);
 
182
  }
 
183
 
 
184
  my @extra_options = ();  # extra arguments to getoptions
 
185
  if (defined $arg{command_line_options}) {
 
186
    @extra_options = @{$arg{command_line_options}};
 
187
  }
 
188
 
 
189
  # Make a --quiet function that turns off verbosity
 
190
  $arg{opthash}->{quiet} = sub { $arg{opthash}->{verbose} = 0; };
 
191
 
 
192
  unless (GetOptions($arg{opthash},
 
193
                    @default_options,
 
194
                    @extra_options,
 
195
                    )) {
 
196
    print STDERR $arg{usage};
 
197
    exit 1;
 
198
  }
 
199
  if ($arg{opthash}->{help}) {
 
200
    print $arg{usage};
 
201
    exit 0;
 
202
  }
 
203
 
 
204
  # Get rid of the quiet handler
 
205
  delete $arg{opthash}->{quiet};
 
206
 
 
207
  # If we've been given a hashref, save our options there at this
 
208
  # stage, so the caller can see what was passed on the command line.
 
209
  # Unfortunately, perl has no .replace function, so we iterate.
 
210
  if (ref $arg{command_line_hash} eq 'HASH') {
 
211
    while (my ($k, $v) = each %{$arg{opthash}}) {
 
212
      $arg{command_line_hash}->{$k} = $v;
 
213
    }
 
214
  }
 
215
 
 
216
  # Use the default config file
 
217
  if (not defined $arg{opthash}->{config}) {
 
218
    $arg{opthash}->{config} = $DEFAULT_CONFIG_FILE;
 
219
  }
 
220
 
 
221
  # We need to decide whether to be verbose about reading the config file
 
222
  # Currently we just do it if global verbosity > 2
 
223
  my $verbose_config = 0;
 
224
  if (defined $arg{opthash}->{verbose}
 
225
      and $arg{opthash}->{verbose} > 2) {
 
226
    $verbose_config = 1;
 
227
  }
 
228
 
 
229
  # Read options from the config file, passing along the options we've
 
230
  # gotten so far
 
231
  read_config(
 
232
      file => $arg{opthash}->{config},
 
233
      opthash => $arg{opthash},
 
234
      verbose => $verbose_config,
 
235
  );
 
236
 
 
237
  # The "verbose" option gets compared a lot and needs to be defined
 
238
  $arg{opthash}->{verbose} ||= 0;
 
239
 
 
240
  # The "hostname" option is set specially if it's not defined
 
241
  if (not defined $arg{opthash}->{hostname}) {
 
242
    use Sys::Hostname;
 
243
    $arg{opthash}->{hostname} = hostname;
 
244
  }
 
245
 
 
246
  # We can require some options to be set
 
247
  if (ref $arg{required_options} eq 'ARRAY') {
 
248
    for my $option (@{$arg{required_options}}) {
 
249
      if (not defined $arg{opthash}->{$option}) {
 
250
        croak "Required option '$option' not given on command line or specified in config file!\n";
 
251
      }
 
252
    }
 
253
  }
 
254
 
 
255
  return $arg{opthash};
 
256
}
 
257
 
 
258
sub prompt ($) {
 
259
  my ($prompt) = @_;
 
260
  if (not defined $term) {
 
261
    require Term::ReadLine;
 
262
    $term = new Term::ReadLine 'slack'
 
263
  }
 
264
 
 
265
  $term->readline($prompt);
 
266
}
 
267
 
 
268
 
 
269
# Calls the callback on absolute pathnames of files in the source directory,
 
270
# and also on names of directories that don't exist in the destination
 
271
# directory (i.e. where $source/foo exists but $destination/foo does not).
 
272
sub find_files_to_install ($$$) {
 
273
  my ($source, $destination, $callback) = @_;
 
274
  return find ({
 
275
      wanted => sub {
 
276
        if (-l or not -d _) {
 
277
          # Copy all files, links, etc
 
278
          my $file = $File::Find::name;
 
279
          &$callback($file);
 
280
        } elsif (-d _) {
 
281
          # For directories, we only want to copy it if it doesn't
 
282
          # exist in the destination yet.
 
283
          my $dir = $File::Find::name;
 
284
          # We know the root directory will exist (we make it above),
 
285
          # so skip the base of the source
 
286
          (my $short_source = $source) =~ s#/$##;
 
287
          return if $dir eq $short_source;
 
288
 
 
289
          # Strip the $source from the path,
 
290
          # so we can build the destination dir from it.
 
291
          my $subdir = $dir;
 
292
          ($subdir =~ s#^$source##)
 
293
            or croak "sub failed: $source|$subdir";
 
294
 
 
295
          if (not -d "$destination/$subdir") {
 
296
            &$callback($dir);
 
297
          }
 
298
        }
 
299
      }
 
300
    },
 
301
    $source,
 
302
  );
 
303
}
 
304
 
 
305
1;