← Back to branch summary

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

« back to all changes in this revision

Viewing changes to test/test_util.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:
test/test_util.pm
 
1
package test_util ;
 
2
use strict;
 
3
use warnings;
 
4
 
 
5
use Cwd;
 
6
use Sys::Hostname;
 
7
 
 
8
{
 
9
    require Exporter;
 
10
    use vars qw(@ISA @EXPORT @EXPORT_OK);
 
11
    
 
12
    @ISA = qw(Exporter);
 
13
    @EXPORT = ();
 
14
    @EXPORT_OK = qw(gen_config_file gen_wanted write_to_file);
 
15
}
 
16
use vars qw($test_config_file %test_config @test_roles $test_hostname);
 
17
use vars qw($TEST_TMPDIR);
 
18
push @EXPORT, qw($test_config_file %test_config @test_roles $test_hostname);
 
19
 
 
20
# Because all the scripts chdir('/'), we need to know the cwd for our configs
 
21
my $TEST_DIR = getcwd;
 
22
$TEST_TMPDIR = getcwd."/tmp";
 
23
$test_hostname = hostname;
 
24
 
 
25
$test_config_file = "$TEST_DIR/slack.conf";
 
26
%test_config = (
 
27
    'source' => "$TEST_DIR/testsource",
 
28
    'role-list' => "$TEST_DIR/roles.conf",
 
29
    'cache' => "$TEST_TMPDIR/cache",
 
30
    'stage' => "$TEST_TMPDIR/stage",
 
31
    'root' => "$TEST_TMPDIR/root",
 
32
    'backup-dir' => "$TEST_TMPDIR/backups",
 
33
    'verbose' => 0,
 
34
);
 
35
 
 
36
@test_roles = sort qw(role1 role2.sub role3.sub.sub);
 
37
 
 
38
sub gen_config_file ($$) {
 
39
    my ($template_file, $file) = @_;
 
40
 
 
41
    open(TEMPLATE, "<", "$template_file")
 
42
        or die "Could not open template file $template_file: $!";
 
43
    open(FILE, ">", $file)
 
44
        or die "Could not open output file $file: $!";
 
45
 
 
46
    while(<TEMPLATE>) {
 
47
        s/__TEST_DIR__/$TEST_DIR/g;
 
48
        s/__TEST_TMPDIR__/$TEST_TMPDIR/g;
 
49
        s/__HOSTNAME__/$test_hostname/g;
 
50
        s/__ROLES__/join(" ", @test_roles)/ge;
 
51
        print FILE;
 
52
    }
 
53
    close(TEMPLATE)
 
54
        or die "Could not close template file $template_file: $!";
 
55
    close(FILE)
 
56
        or die "Could not close output file $file: $!";
 
57
}
 
58
 
 
59
# Transform globs into regexes, since I can't find a function to check
 
60
# glob matches on strings.
 
61
sub glob_to_regex ($) {
 
62
    my ($pat) = @_;
 
63
    $pat =~ s#/$##;                # strip trailing slashes
 
64
    $pat =~ s#([./^\$()+])#\\$1#g; # escape re metachars
 
65
    $pat =~ s#([?*])#.$1#g;        # convert glob metachars
 
66
    return qr(\A$pat\z);
 
67
}
 
68
 
 
69
# This is to help with comparing lists of files in two directory trees.
 
70
#
 
71
# Returns a wanted function for File::Find which will maintain a file list
 
72
# in a hash that looks like:
 
73
#       filename => filetype
 
74
# where valid filetypes are:
 
75
#       d       directory
 
76
#       f       regular file
 
77
#       x       executable file
 
78
#       -       unknown
 
79
# and which will skip files rsync is known to skip.
 
80
# Symlinks are dereferenced because that's what we tell rsync to do, too.
 
81
#
 
82
# Takes as arguments a basename which will be stripped off file names
 
83
# and a hash reference (in which to maintain the file list above)
 
84
sub gen_wanted ($$) {
 
85
    my ($base, $hashref) = @_;
 
86
 
 
87
    my @cvs_exclude;
 
88
    {
 
89
        # Suppress spurious warning about the # and , characters below
 
90
        no warnings;
 
91
        # Straight out of the rsync manpage section for --cvs-exclude
 
92
        @cvs_exclude = qw(
 
93
          RCS  SCCS  CVS  CVS.adm  RCSLOG  cvslog.*  tags TAGS .make.state
 
94
          .nse_depinfo *~ #* .#* ,* _$* *$ *.old *.bak *.BAK *.orig  *.rej
 
95
          .del-* *.a *.olb *.o *.obj *.so *.exe *.Z *.elc *.ln core .svn/
 
96
        );
 
97
    }
 
98
    @cvs_exclude = map {glob_to_regex($_)} @cvs_exclude;
 
99
 
 
100
    return sub {
 
101
        # Prune out files in the CVS exclude list used by rsync
 
102
        for my $pat (@cvs_exclude) {
 
103
            if (m/$pat/) {
 
104
                $File::Find::prune = 1;
 
105
                return;
 
106
            }
 
107
        }
 
108
        my $filetype = '-';
 
109
        if (-f) {
 
110
            if (-x _) {
 
111
                $filetype = 'x';
 
112
            } else {
 
113
                $filetype = 'f';
 
114
            }
 
115
        } elsif (-d _) {
 
116
            $filetype = 'd';
 
117
        }
 
118
 
 
119
        my $filename = $File::Find::name;
 
120
        # Try to strip off the base
 
121
        return unless ($filename =~ s#^$base/##); 
 
122
        $hashref->{$filename} = $filetype;
 
123
    };
 
124
}
 
125
 
 
126
sub write_to_file ($$) {
 
127
    my ($file, $text) = @_;
 
128
    my $fh;
 
129
    open($fh, '>', $file)
 
130
        or die "Could not open $file for writing: $!";
 
131
    print $fh $text
 
132
        or die "Could not write to $file: $!";
 
133
    close($fh)
 
134
        or die "Could not close $file: $!";
 
135
}
 
136
 
 
137
1;