git.sur5r.net Git - bacula/bacula/blob - regress/scripts/functions.pm

   1 ################################################################
   2 use strict;
   3
   4 =head1 LICENSE
   5
   6    Bacula® - The Network Backup Solution
   7
   8    Copyright (C) 2000-2009 Free Software Foundation Europe e.V.
   9
  10    The main author of Bacula is Kern Sibbald, with contributions from
  11    many others, a complete list can be found in the file AUTHORS.
  12
  13    This program is Free Software; you can redistribute it and/or
  14    modify it under the terms of version two of the GNU General Public
  15    License as published by the Free Software Foundation plus additions
  16    that are listed in the file LICENSE.
  17
  18    This program is distributed in the hope that it will be useful, but
  19    WITHOUT ANY WARRANTY; without even the implied warranty of
  20    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
  21    General Public License for more details.
  22
  23    You should have received a copy of the GNU General Public License
  24    along with this program; if not, write to the Free Software
  25    Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  26    02110-1301, USA.
  27
  28    Bacula® is a registered trademark of Kern Sibbald.
  29    The licensor of Bacula is the Free Software Foundation Europe
  30    (FSFE), Fiduciary Program, Sumatrastrasse 25, 8006 Zurich,
  31    Switzerland, email:ftf@fsfeurope.org.
  32
  33 =cut
  34
  35 package scripts::functions;
  36 # Export all functions needed to be used by a simple
  37 # perl -Mscripts::functions -e '' script
  38 use Exporter;
  39 our @ISA = qw(Exporter);
  40 our @EXPORT =  qw(update_some_files create_many_files check_multiple_copies
  41                   update_client $HOST $BASEPORT add_to_backup_list check_volume_size
  42                   check_min_volume_size check_max_volume_size $estat $bstat $rstat $zstat
  43                   $cwd $bin $scripts $conf $rscripts $tmp $working extract_resource
  44                   $db_name $db_user $db_password $src $tmpsrc);
  45
  46
  47 use File::Copy qw/copy/;
  48
  49 our ($cwd, $bin, $scripts, $conf, $rscripts, $tmp, $working, $estat, $bstat, $zstat, $rstat,
  50      $db_name, $db_user, $db_password, $src, $tmpsrc, $HOST, $BASEPORT);
  51
  52 END {
  53     if ($estat || $rstat || $zstat || $bstat) {
  54         exit 1;
  55     }
  56 }
  57
  58 BEGIN {
  59     # start by loading the ./config file
  60     my ($envar, $enval);
  61     if (! -f "./config") {
  62         die "Could not find ./config file\n";
  63     }
  64     # load the ./config file in a subshell doesn't allow to use "env" to display all variable
  65     open(IN, ". ./config; env |") or die "Could not run shell: $!\n";
  66     while ( my $l = <IN> ) {
  67         chomp ($l);
  68         ($envar,$enval) = split (/=/,$l,2);
  69         $ENV{$envar} = $enval;
  70     }
  71     close(IN);
  72     $cwd = `pwd`;
  73     chomp($cwd);
  74
  75     # set internal variable name and update environment variable
  76     $ENV{db_name} = $db_name = $ENV{db_name} || 'regress';
  77     $ENV{db_user} = $db_user = $ENV{db_user} || 'regress';
  78     $ENV{db_password} = $db_password = $ENV{db_password} || '';
  79
  80     $ENV{bin}      = $bin      =  $ENV{bin}      || "$cwd/bin";
  81     $ENV{tmp}      = $tmp      =  $ENV{tmp}      || "$cwd/tmp";
  82     $ENV{src}      = $src      =  $ENV{src}      || "$cwd/src";
  83     $ENV{conf}     = $conf     =  $ENV{conf}     || $bin;
  84     $ENV{scripts}  = $scripts  =  $ENV{scripts}  || $bin;
  85     $ENV{tmpsrc}   = $tmpsrc   =  $ENV{tmpsrc}   || "$cwd/tmp/build";
  86     $ENV{working}  = $working  =  $ENV{working}  || "$cwd/working";
  87     $ENV{rscripts} = $rscripts =  $ENV{rscripts} || "$cwd/scripts";
  88     $ENV{HOST}     = $HOST     =  $ENV{HOST}     || "localhost";
  89     $ENV{BASEPORT} = $BASEPORT =  $ENV{BASEPORT} || "8101";
  90
  91     $estat = $rstat = $bstat = $zstat = 0;
  92 }
  93
  94 sub extract_resource
  95 {
  96     my ($file, $type, $name) = @_;
  97
  98     open(FP, $file) or die "Can't open $file";
  99     my $content = join("", <FP>);
 100
 101     if ($content =~ m/(^$type {[^}]+?Name\s*=\s*"?$name"?[^}]+?^})/ms) {
 102         print $1, "\n";
 103     }
 104
 105     close(FP);
 106 }
 107
 108 sub check_min_volume_size
 109 {
 110     my ($size, @vol) = @_;
 111     my $ret=0;
 112
 113     foreach my $v (@vol) {
 114         if (! -f "$tmp/$v") {
 115             print "ERR: $tmp/$v not accessible\n";
 116             $ret++;
 117             next;
 118         }
 119         if (-s "$tmp/$v" < $size) {
 120             print "ERR: $tmp/$v too small\n";
 121             $ret++;
 122         }
 123     }
 124     $estat+=$ret;
 125     return $ret;
 126 }
 127
 128 sub check_max_volume_size
 129 {
 130     my ($size, @vol) = @_;
 131     my $ret=0;
 132
 133     foreach my $v (@vol) {
 134         if (! -f "$tmp/$v") {
 135             print "ERR: $tmp/$v not accessible\n";
 136             $ret++;
 137             next;
 138         }
 139         if (-s "$tmp/$v" > $size) {
 140             print "ERR: $tmp/$v too big\n";
 141             $ret++;
 142         }
 143     }
 144     $estat+=$ret;
 145     return $ret;
 146 }
 147
 148 sub add_to_backup_list
 149 {
 150     open(FP, ">>$tmp/file-list") or die "Can't open $tmp/file-list for update $!";
 151     print FP join("\n", @_);
 152     close(FP);
 153 }
 154
 155 # update client definition for the current test
 156 # it permits to test remote client
 157 sub update_client
 158 {
 159     my ($new_passwd, $new_address, $new_port) = @_;
 160     my $in_client=0;
 161
 162     open(FP, "$conf/bacula-dir.conf") or die "can't open source $!";
 163     open(NEW, ">$tmp/bacula-dir.conf.$$") or die "can't open dest $!";
 164     while (my $l = <FP>) {
 165         if (!$in_client && $l =~ /^Client {/) {
 166             $in_client=1;
 167         }
 168
 169         if ($in_client && $l =~ /Address/i) {
 170             $l = "Address = $new_address\n";
 171         }
 172
 173         if ($in_client && $l =~ /FDPort/i) {
 174             $l = "FDPort = $new_port\n";
 175         }
 176
 177         if ($in_client && $l =~ /Password/i) {
 178             $l = "Password = \"$new_passwd\"\n";
 179         }
 180
 181         if ($in_client && $l =~ /^}/) {
 182             $in_client=0;
 183         }
 184         print NEW $l;
 185     }
 186     close(FP);
 187     close(NEW);
 188     my $ret = copy("$tmp/bacula-dir.conf.$$", "$conf/bacula-dir.conf");
 189     unlink("$tmp/bacula-dir.conf.$$");
 190     return $ret;
 191 }
 192
 193 # open a directory and update all files
 194 sub update_some_files
 195 {
 196     my ($dest)=@_;
 197     my $t=rand();
 198     my $f;
 199     my $nb=0;
 200     print "Update files in $dest\n";
 201     opendir(DIR, $dest) || die "$!";
 202     map {
 203         $f = "$dest/$_";
 204         if (-f $f) {
 205             open(FP, ">$f") or die "$f $!";
 206             print FP "$t update $f\n";
 207             close(FP);
 208             $nb++;
 209         }
 210     } readdir(DIR);
 211     closedir DIR;
 212     print "$nb files updated\n";
 213 }
 214
 215 # create big number of files in a given directory
 216 # Inputs: dest  destination directory
 217 #         nb    number of file to create
 218 # Example:
 219 # perl -Mscripts::functions -e 'create_many_files("$cwd/files", 100000)'
 220 sub create_many_files
 221 {
 222     my ($dest, $nb) = @_;
 223     my $base;
 224     my $dir=$dest;
 225     $nb = $nb || 750000;
 226     mkdir $dest;
 227     $base = chr($nb % 26 + 65); # We use a base directory A-Z
 228
 229     # already done
 230     if (-f "$dest/$base/a${base}a${nb}aaa${base}") {
 231         print "Files already created\n";
 232         return;
 233     }
 234
 235     # auto flush stdout for dots
 236     $| = 1;
 237     print "Create $nb files into $dest\n";
 238     for(my $i=0; $i < 26; $i++) {
 239         $base = chr($i + 65);
 240         mkdir("$dest/$base") if (! -d "$dest/$base");
 241     }
 242     for(my $i=0; $i<=$nb; $i++) {
 243         $base = chr($i % 26 + 65);
 244         open(FP, ">$dest/$base/a${base}a${i}aaa$base") or die "$dest/$base $!";
 245         print FP "$i\n";
 246         close(FP);
 247
 248         open(FP, ">$dir/b${base}a${i}csq$base") or die "$dir $!";
 249         print FP "$base $i\n";
 250         close(FP);
 251
 252         if (!($i % 100)) {
 253             $dir = "$dest/$base/$base$i$base";
 254             mkdir $dir;
 255         }
 256         print "." if (!($i % 10000));
 257     }
 258     print "\n";
 259 }
 260
 261 sub check_encoding
 262 {
 263     if (grep {/Wanted SQL_ASCII, got UTF8/}
 264         `${bin}/bacula-dir -d50 -t -c ${conf}/bacula-dir.conf 2>&1`)
 265     {
 266         print "Found database encoding problem, please modify the ",
 267               "database encoding (SQL_ASCII)\n";
 268         exit 1;
 269     }
 270 }
 271
 272 # This test ensure that 'list copies' displays only each copy one time
 273 #
 274 # Input: read stream from stdin or with file list argument
 275 #        check the number of copies with the ARGV[1]
 276 # Output: exit(1) if something goes wrong and print error
 277 sub check_multiple_copies
 278 {
 279     my ($nb_to_found) = @_;
 280
 281     my $in_list_copies=0;       # are we or not in a list copies block
 282     my $nb_found=0;             # count the number of copies found
 283     my $ret = 0;
 284     my %seen;
 285
 286     while (my $l = <>)          # read all files to check
 287     {
 288         if ($l =~ /list copies/) {
 289             $in_list_copies=1;
 290             %seen = ();
 291             next;
 292         }
 293
 294         # not in a list copies anymore
 295         if ($in_list_copies && $l =~ /^ /) {
 296             $in_list_copies=0;
 297             next;
 298         }
 299
 300         # list copies ouput:
 301         # |     3 | Backup.2009-09-28 |  9 | DiskChangerMedia |
 302         if ($in_list_copies && $l =~ /^\|\s+\d+/) {
 303             my (undef, $jobid, undef, $copyid, undef) = split(/\s*\|\s*/, $l);
 304             if (exists $seen{$jobid}) {
 305                 print "ERROR: $jobid/$copyid already known as $seen{$jobid}\n";
 306                 $ret = 1;
 307             } else {
 308                 $seen{$jobid}=$copyid;
 309                 $nb_found++;
 310             }
 311         }
 312     }
 313
 314     # test the number of copies against the given arg
 315     if ($nb_to_found && ($nb_to_found != $nb_found)) {
 316         print "ERROR: Found wrong number of copies ",
 317               "($nb_to_found != $nb_found)\n";
 318         exit 1;
 319     }
 320
 321     exit $ret;
 322 }
 323
 324 1;