← Back to branch summary

~drizzle-trunk/drizzle/development

« back to all changes in this revision

Viewing changes to tests/lib/dtr_misc.pl

Merged vcol stuff.

Show diffs side-by-side

added added

removed removed

Lines of Context:
tests/lib/dtr_misc.pl
1
 
# -*- cperl -*-
2
 
# Copyright (C) 2004-2006 MySQL AB
3
 
# 
4
 
# This program is free software; you can redistribute it and/or modify
5
 
# it under the terms of the GNU General Public License as published by
6
 
# the Free Software Foundation; version 2 of the License.
7
 
# 
8
 
# This program is distributed in the hope that it will be useful,
9
 
# but WITHOUT ANY WARRANTY; without even the implied warranty of
10
 
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
11
 
# GNU General Public License for more details.
12
 
# 
13
 
# You should have received a copy of the GNU General Public License
14
 
# along with this program; if not, write to the Free Software
15
 
# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
16
 
 
17
 
# This is a library file used by the Perl version of drizzle-test-run,
18
 
# and is part of the translation of the Bourne shell script with the
19
 
# same name.
20
 
 
21
 
use strict;
22
 
use File::Find;
23
 
 
24
 
sub dtr_native_path($);
25
 
sub dtr_init_args ($);
26
 
sub dtr_add_arg ($$@);
27
 
sub dtr_path_exists(@);
28
 
sub dtr_script_exists(@);
29
 
sub dtr_file_exists(@);
30
 
sub dtr_exe_exists(@);
31
 
sub dtr_exe_maybe_exists(@);
32
 
sub dtr_copy_dir($$);
33
 
sub dtr_rmtree($);
34
 
sub dtr_same_opts($$);
35
 
sub dtr_cmp_opts($$);
36
 
 
37
 
##############################################################################
38
 
#
39
 
#  Misc
40
 
#
41
 
##############################################################################
42
 
 
43
 
# Convert path to OS native format
44
 
sub dtr_native_path($)
45
 
{
46
 
  my $path= shift;
47
 
 
48
 
  # drizzle version before 5.0 still use cygwin, no need
49
 
  # to convert path
50
 
  return $path
51
 
    if ($::drizzle_version_id < 50000);
52
 
 
53
 
  $path=~ s/\//\\/g
54
 
    if ($::glob_win32);
55
 
  return $path;
56
 
}
57
 
 
58
 
 
59
 
# FIXME move to own lib
60
 
 
61
 
sub dtr_init_args ($) {
62
 
  my $args = shift;
63
 
  $$args = [];                            # Empty list
64
 
}
65
 
 
66
 
sub dtr_add_arg ($$@) {
67
 
  my $args=   shift;
68
 
  my $format= shift;
69
 
  my @fargs = @_;
70
 
 
71
 
  push(@$args, sprintf($format, @fargs));
72
 
}
73
 
 
74
 
##############################################################################
75
 
 
76
 
#
77
 
# NOTE! More specific paths should be given before less specific.
78
 
# For example /client/debug should be listed before /client
79
 
#
80
 
sub dtr_path_exists (@) {
81
 
  foreach my $path ( @_ )
82
 
  {
83
 
    return $path if -e $path;
84
 
  }
85
 
  if ( @_ == 1 )
86
 
  {
87
 
    dtr_error("Could not find $_[0]");
88
 
  }
89
 
  else
90
 
  {
91
 
    dtr_error("Could not find any of " . join(" ", @_));
92
 
  }
93
 
}
94
 
 
95
 
 
96
 
#
97
 
# NOTE! More specific paths should be given before less specific.
98
 
# For example /client/debug should be listed before /client
99
 
#
100
 
sub dtr_script_exists (@) {
101
 
  foreach my $path ( @_ )
102
 
  {
103
 
    if($::glob_win32)
104
 
    {
105
 
      return $path if -f $path;
106
 
    }
107
 
    else
108
 
    {
109
 
      return $path if -x $path;
110
 
    }
111
 
  }
112
 
  if ( @_ == 1 )
113
 
  {
114
 
    dtr_error("Could not find $_[0]");
115
 
  }
116
 
  else
117
 
  {
118
 
    dtr_error("Could not find any of " . join(" ", @_));
119
 
  }
120
 
}
121
 
 
122
 
 
123
 
#
124
 
# NOTE! More specific paths should be given before less specific.
125
 
# For example /client/debug should be listed before /client
126
 
#
127
 
sub dtr_file_exists (@) {
128
 
  foreach my $path ( @_ )
129
 
  {
130
 
    return $path if -e $path;
131
 
  }
132
 
  return "";
133
 
}
134
 
 
135
 
 
136
 
#
137
 
# NOTE! More specific paths should be given before less specific.
138
 
# For example /client/debug should be listed before /client
139
 
#
140
 
sub dtr_exe_maybe_exists (@) {
141
 
  my @path= @_;
142
 
 
143
 
  map {$_.= ".exe"} @path if $::glob_win32;
144
 
  map {$_.= ".nlm"} @path if $::glob_netware;
145
 
  foreach my $path ( @path )
146
 
  {
147
 
    if($::glob_win32)
148
 
    {
149
 
      return $path if -f $path;
150
 
    }
151
 
    else
152
 
    {
153
 
      return $path if -x $path;
154
 
    }
155
 
  }
156
 
  return "";
157
 
}
158
 
 
159
 
 
160
 
#
161
 
# NOTE! More specific paths should be given before less specific.
162
 
# For example /client/debug should be listed before /client
163
 
#
164
 
sub dtr_exe_exists (@) {
165
 
  my @path= @_;
166
 
  if (my $path= dtr_exe_maybe_exists(@path))
167
 
  {
168
 
    return $path;
169
 
  }
170
 
  # Could not find exe, show error
171
 
  if ( @path == 1 )
172
 
  {
173
 
    dtr_error("Could not find $path[0]");
174
 
  }
175
 
  else
176
 
  {
177
 
    dtr_error("Could not find any of " . join(" ", @path));
178
 
  }
179
 
}
180
 
 
181
 
 
182
 
sub dtr_copy_dir($$) {
183
 
  my $from_dir= shift;
184
 
  my $to_dir= shift;
185
 
 
186
 
  # dtr_verbose("Copying from $from_dir to $to_dir");
187
 
 
188
 
  mkpath("$to_dir");
189
 
  opendir(DIR, "$from_dir")
190
 
    or dtr_error("Can't find $from_dir$!");
191
 
  for(readdir(DIR)) {
192
 
    next if "$_" eq "." or "$_" eq "..";
193
 
    if ( -d "$from_dir/$_" )
194
 
    {
195
 
      dtr_copy_dir("$from_dir/$_", "$to_dir/$_");
196
 
      next;
197
 
    }
198
 
    copy("$from_dir/$_", "$to_dir/$_");
199
 
  }
200
 
  closedir(DIR);
201
 
 
202
 
}
203
 
 
204
 
 
205
 
sub dtr_rmtree($) {
206
 
  my ($dir)= @_;
207
 
  dtr_verbose("dtr_rmtree: $dir");
208
 
 
209
 
  # Try to use File::Path::rmtree. Recent versions
210
 
  # handles removal of directories and files that don't
211
 
  # have full permissions, while older versions
212
 
  # may have a problem with that and we use our own version
213
 
 
214
 
  eval { rmtree($dir); };
215
 
  if ( $@ ) {
216
 
    dtr_warning("rmtree($dir) failed, trying with File::Find...");
217
 
 
218
 
    my $errors= 0;
219
 
 
220
 
    # chmod
221
 
    find( {
222
 
           no_chdir => 1,
223
 
           wanted => sub {
224
 
             chmod(0777, $_)
225
 
               or dtr_warning("couldn't chmod(0777, $_): $!") and $errors++;
226
 
           }
227
 
          },
228
 
          $dir
229
 
        );
230
 
 
231
 
    # rm
232
 
    finddepth( {
233
 
           no_chdir => 1,
234
 
           wanted => sub {
235
 
             my $file= $_;
236
 
             # Use special underscore (_) filehandle, caches stat info
237
 
             if (!-l $file and -d _ ) {
238
 
               rmdir($file) or
239
 
                 dtr_warning("couldn't rmdir($file): $!") and $errors++;
240
 
             } else {
241
 
               unlink($file)
242
 
                 or dtr_warning("couldn't unlink($file): $!") and $errors++;
243
 
             }
244
 
           }
245
 
          },
246
 
          $dir
247
 
        );
248
 
 
249
 
    dtr_error("Failed to remove '$dir'") if $errors;
250
 
 
251
 
    dtr_report("OK, that worked!");
252
 
  }
253
 
}
254
 
 
255
 
 
256
 
sub dtr_same_opts ($$) {
257
 
  my $l1= shift;
258
 
  my $l2= shift;
259
 
  return dtr_cmp_opts($l1,$l2) == 0;
260
 
}
261
 
 
262
 
sub dtr_cmp_opts ($$) {
263
 
  my $l1= shift;
264
 
  my $l2= shift;
265
 
 
266
 
  my @l1= @$l1;
267
 
  my @l2= @$l2;
268
 
 
269
 
  return -1 if @l1 < @l2;
270
 
  return  1 if @l1 > @l2;
271
 
 
272
 
  while ( @l1 )                         # Same length
273
 
  {
274
 
    my $e1= shift @l1;
275
 
    my $e2= shift @l2;
276
 
    my $cmp= ($e1 cmp $e2);
277
 
    return $cmp if $cmp != 0;
278
 
  }
279
 
 
280
 
  return 0;                             # They are the same
281
 
}
282
 
 
283
 
#
284
 
# Compare two arrays and put all unequal elements into a new one
285
 
#
286
 
sub dtr_diff_opts ($$) {
287
 
  my $l1= shift;
288
 
  my $l2= shift;
289
 
  my $f;
290
 
  my $l= [];
291
 
  foreach my $e1 (@$l1) 
292
 
  {    
293
 
    $f= undef;
294
 
    foreach my $e2 (@$l2) 
295
 
    {
296
 
      $f= 1 unless ($e1 ne $e2);
297
 
    }
298
 
    push(@$l, $e1) unless (defined $f);
299
 
  }
300
 
  foreach my $e2 (@$l2) 
301
 
  {
302
 
    $f= undef;
303
 
    foreach my $e1 (@$l1) 
304
 
    {
305
 
      $f= 1 unless ($e1 ne $e2);
306
 
    }
307
 
    push(@$l, $e2) unless (defined $f);
308
 
  }
309
 
  return $l;
310
 
}
311
 
 
312
 
1;