source3/script/tests/test_smbclient_tarmode.pl

   1 #!/usr/bin/perl
   2
   3 # Unix SMB/CIFS implementation.
   4 # Test suite for the tar backup mode of smbclient.
   5 # Copyright (C) Aurélien Aptel 2013
   6
   7 # This program is free software; you can redistribute it and/or modify
   8 # it under the terms of the GNU General Public License as published by
   9 # the Free Software Foundation; either version 3 of the License, or
  10 # (at your option) any later version.
  11
  12 # This program is distributed in the hope that it will be useful,
  13 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 # GNU General Public License for more details.
  16
  17 # You should have received a copy of the GNU General Public License
  18 # along with this program.  If not, see <http://www.gnu.org/licenses/>.
  19
  20 =head1 NAME
  21
  22 C<test_smbclient_tarmode.pl> - Test for smbclient tar backup feature
  23
  24 =cut
  25
  26 use v5.14;
  27 use strict;
  28 use warnings;
  29 no warnings 'experimental::smartmatch';
  30
  31 use Archive::Tar;
  32 use Data::Dumper;
  33 use Digest::MD5 qw/md5_hex/;
  34 use File::Path qw/make_path remove_tree/;
  35 use File::Spec;
  36 use File::Temp;
  37 use Getopt::Long;
  38 use Pod::Usage;
  39 use Term::ANSIColor;
  40
  41 sub d {print Dumper @_;}
  42
  43 # DEFAULTS
  44 # 'our' to make them available in the File package
  45 our $USER      = '';
  46 our $PW        = '';
  47 our $HOST      = 'localhost';
  48 our $IP        = '';
  49 our $SHARE     = 'public';
  50 our $DIR       = 'tar_test_dir';
  51 our $LOCALPATH = '/media/data/smb-test';
  52 our $TMP       = File::Temp->newdir();
  53 our $BIN       = 'smbclient';
  54 our $SUBUNIT   = 0;
  55
  56 my $SELECTED_TEST = '';
  57 my $LIST_TEST = 0;
  58
  59 my @SMBARGS   = ();
  60
  61 our $DEBUG = 0;
  62 our $VERBOSE = 0;
  63 my $MAN   = 0;
  64 my $HELP  = 0;
  65 my $CLEAN = 0;
  66
  67 # all tests
  68 my @TESTS = (
  69 #   ['test helper',                                 \&test_helper],
  70     ['create, normal files (no attributes)',        \&test_creation_normal,      'normal'],
  71     ['create, normal nested files (no attributes)', \&test_creation_normal,      'nested'],
  72     ['create, normal files (interactive)',          \&test_creation_normal,      'inter'],
  73     ['create, large file',                          \&test_creation_large_file],
  74     ['create, long path',                           \&test_creation_long_path],
  75     ['create, incremental with -g',                 \&test_creation_incremental, '-g'],
  76     ['create, incremental with tarmode',            \&test_creation_incremental, 'tarmode inc'],
  77     ['create, reset archived files with -a',        \&test_creation_reset,       '-a'],
  78     ['create, reset archived files with tarmode',   \&test_creation_reset,       'tarmode reset'],
  79     ['create, files newer than a file',             \&test_creation_newer],
  80     ['create, combination of tarmode filter',       \&test_creation_attr],
  81     ['create, explicit include',                    \&test_creation_include],
  82 #    ['create, explicit exclude',                    \&test_creation_exclude],
  83     ['create, include w/ filelist (F)',             \&test_creation_list],
  84     ['create, wildcard simple',                     \&test_creation_wildcard_simple],
  85     ['create, regex',                               \&test_creation_regex],
  86     ['create, multiple backup in session',          \&test_creation_multiple],
  87     ['extract, normal files',                       \&test_extraction_normal],
  88     ['extract, explicit include',                   \&test_extraction_include],
  89     ['extract, explicit exclude',                   \&test_extraction_exclude],
  90     ['extract, include w/ filelist (F)',            \&test_extraction_list],
  91     ['extract, regex',                              \&test_extraction_regex],
  92 );
  93
  94 =head1 SYNOPSIS
  95
  96  test_smbclient_tarmode.pl [options] -- [smbclient options]
  97
  98  Options:
  99     -h, --help    brief help message
 100     --man         full documentation
 101
 102   Environment:
 103     -u, --user      USER
 104     -p, --password  PW
 105     -h, --host      HOST
 106     -i, --ip        IP
 107     -s, --share     SHARE
 108     -d, --dir       PATH
 109         sub-path to use on the share
 110
 111     -l, --local-path  PATH
 112         path to the root of the samba share on the machine.
 113
 114     -b, --bin  BIN
 115         path to the smbclient binary to use
 116
 117   Test:
 118     --list
 119        list tests
 120
 121     --test N
 122     --test A-B
 123     --test A,B,D-F
 124        only run certain tests (accept list and intervals of numbers)
 125
 126     -v, --verbose
 127        be more verbose
 128
 129     --debug
 130        print command and their output
 131
 132 =cut
 133
 134 GetOptions('u|user=s'       => \$USER,
 135            'p|password=s'   => \$PW,
 136            'h|host=s'       => \$HOST,
 137            'i|ip=s'         => \$IP,
 138            's|share=s'      => \$SHARE,
 139            'd|dir=s'        => \$DIR,
 140            'l|local-path=s' => \$LOCALPATH,
 141            'b|bin=s'        => \$BIN,
 142
 143            'test=s'         => \$SELECTED_TEST,
 144            'list'           => \$LIST_TEST,
 145
 146            'clean'          => \$CLEAN,
 147            'subunit'        => \$SUBUNIT,
 148            'debug'          => \$DEBUG,
 149            'v|verbose'      => \$VERBOSE,
 150            'h|help'         => \$HELP,
 151            'man'            => \$MAN) or pod2usage(2);
 152
 153 pod2usage(0) if $HELP;
 154 pod2usage(-exitval => 0, -verbose => 2) if $MAN;
 155 list_test(), exit 0 if $LIST_TEST;
 156
 157 if ($USER xor $PW) {
 158     die "Need both user and password when one is provided\n";
 159 }
 160 elsif ($USER and $PW) {
 161     push @SMBARGS, '-U'.$USER.'%'.$PW;
 162 }
 163 else {
 164     push @SMBARGS, '-N';
 165 }
 166
 167 if ($IP) {
 168     push @SMBARGS, '-I', $IP;
 169 }
 170
 171 # remaining arguments are passed to smbclient
 172 push @SMBARGS, @ARGV;
 173
 174 # path to store the downloaded tarball
 175 my $TAR = "$TMP/tarmode.tar";
 176
 177 #####
 178
 179 # SANITIZATION
 180
 181 # remove all final slashes from input paths
 182 $LOCALPATH =~ s{[/\\]+$}{}g;
 183 $SHARE =~ s{[/\\]+$}{}g;
 184 $HOST =~ s{[/\\]+$}{}g;
 185 $DIR =~ s{[/\\]+$}{}g;
 186
 187 if (!-d $LOCALPATH) {
 188     die "Local path '$LOCALPATH' is not a directory.\n";
 189 }
 190
 191 if ($CLEAN) {
 192     # clean the whole root first
 193     remove_tree($LOCALPATH, { keep_root => 1 });
 194 }
 195
 196 if ($DEBUG) {
 197     $VERBOSE = 1;
 198 }
 199
 200 #####
 201
 202 # RUN TESTS
 203
 204 my @selection = parse_test_string($SELECTED_TEST);
 205
 206 if ($SELECTED_TEST eq '') {
 207     run_test(@TESTS);
 208 } elsif (@selection > 0) {
 209     run_test(@selection);
 210 } else {
 211     die "Test selection '$SELECTED_TEST' is invalid\n";
 212 }
 213
 214 #################################
 215
 216 =head1 DOCUMENTATION
 217
 218 =head2 Defining a test
 219
 220 =over
 221
 222 =item * Create a function C<test_yourtest>
 223
 224 =item * Use the File module, documented below
 225
 226 =item * Use C<smb_tar>, C<smb_client>, C<check_tar> or C<check_remote>
 227
 228 =item * Return number of error
 229
 230 =item * Add function to C<@TESTS>
 231
 232 =back
 233
 234 The function must be placed in the C<@TESTS> list along with a short
 235 description and optional arguments.
 236
 237 =cut
 238
 239 sub test_creation_newer {
 240     my @files;
 241     my $dt = 3000;
 242
 243     # create oldest file at - DT
 244     my $oldest = File->new_remote('oldest');
 245     $oldest->set_time(time - $dt);
 246
 247     # create limit file
 248     my $limit = File->new_local("$TMP/limit");
 249
 250     # create newA file at + DT
 251     my $newA = File->new_remote('newA');
 252     $newA->set_time(time + $dt);
 253
 254     # create newB file at + DT
 255     my $newB = File->new_remote('newB');
 256     $newB->set_time(time + $dt);
 257
 258     # get files newer than limit_file
 259     push @files, $newA, $newB;
 260
 261     smb_tar('', '-TcN', $limit->localpath, $TAR, $DIR);
 262     return check_tar($TAR, \@files);
 263 }
 264
 265 sub test_creation_attr {
 266     my @attr = qw/r h s a/;
 267     my @all;
 268     my @inc;
 269     my $err = 0;
 270
 271     # one normal file
 272     my $f = File->new_remote("file-n.txt");
 273     push @all, $f;
 274
 275     # combinations of attributes
 276     for my $n (1..@attr) {
 277         for (combine(\@attr, $n)) {
 278             my @t = @$_;
 279             my $fn = "file-" . join('+', @t) . ".txt";
 280             my $f = File->new_remote($fn);
 281             $f->set_attr(@t);
 282             push @all, $f;
 283         }
 284     }
 285
 286     @inc = grep { !$_->attr('s') } @all;
 287     smb_tar('tarmode nosystem', '-Tc', $TAR, $DIR);
 288     $err += check_tar($TAR, \@inc);
 289
 290     @inc = grep { !$_->attr('h') } @all;
 291     smb_tar('tarmode nohidden', '-Tc', $TAR, $DIR);
 292     $err += check_tar($TAR, \@inc);
 293
 294     @inc = grep { !$_->attr_any('h', 's') } @all;
 295     smb_tar('tarmode nohidden nosystem', '-Tc', $TAR, $DIR);
 296     $err += check_tar($TAR, \@inc);
 297
 298     @inc = grep { $_->attr('a') && !$_->attr_any('h', 's') } @all;
 299     smb_tar('tarmode inc nohidden nosystem', '-Tc', $TAR, $DIR);
 300     $err += check_tar($TAR, \@inc);
 301
 302     $err;
 303 }
 304
 305 sub test_creation_reset {
 306     my ($mode) = @_;
 307
 308     my @files;
 309     my $n = 3;
 310     for (1..$n) {
 311         my $f = File->new_remote("file-$_");
 312         $f->set_attr('a');
 313         push @files, $f;
 314     }
 315
 316     if ($mode =~ /reset/) {
 317         smb_tar('tarmode full reset', '-Tc', $TAR, $DIR);
 318     } else {
 319         smb_tar('', '-Tca', $TAR, $DIR);
 320     }
 321
 322     my $err = check_tar($TAR, \@files);
 323     return $err if ($err > 0);
 324
 325     for my $f (File::list($DIR)) {
 326         if ($f->{attr}{a}) {
 327             printf " ! %s %s\n", $f->attr_str, $f->remotepath;
 328             $err++;
 329         }
 330     }
 331     return $err;
 332 }
 333
 334 sub test_creation_large_file {
 335     my $size = int(15e6); # 15MB
 336     my $f = File->new_remote("fat.jpg", 0, $size);
 337
 338     smb_tar('', '-Tc', $TAR, $DIR);
 339     return check_tar($TAR, [$f]);
 340 }
 341
 342 sub test_creation_long_path {
 343     my $d = "a"x130;
 344     my @all;
 345
 346     for(qw( foo/a bar/b )) {
 347         push @all, File->new_remote("$d/$_");
 348     }
 349
 350     smb_tar('', '-Tc', $TAR, $DIR);
 351     return check_tar($TAR, \@all);
 352 }
 353
 354 sub test_creation_normal {
 355     my ($mode) = @_;
 356
 357     my $prefix = ($mode =~ /nest/) ? "/foo/bar/bar/" : '';
 358     my @files;
 359     my $n = 5;
 360     for (1..$n) {
 361         my $f = File->new_remote($prefix."file-$_");
 362         push @files, $f;
 363     }
 364
 365     if ($mode =~ /inter/) {
 366         smb_tar("tar c $TAR $DIR", '');
 367     } else {
 368         smb_tar('tarmode full', '-Tc', $TAR, $DIR);
 369     }
 370     return check_tar($TAR, \@files);
 371 }
 372
 373 sub test_creation_incremental {
 374     my ($mode) = @_;
 375
 376     my @files;
 377     my $n = 10;
 378     for (1..$n) {
 379         my $f = File->new_remote("file-$_");
 380
 381         # set archive bit on ~half of them
 382         if ($_ < $n/2) {
 383             $f->set_attr('a');
 384             push @files, $f;
 385         }
 386         else {
 387             $f->set_attr((qw/n r s h/)[$_ % 4]);
 388         }
 389     }
 390
 391     if ($mode =~ /inc/) {
 392         smb_tar('tarmode inc', '-Tc', $TAR, $DIR);
 393     } else {
 394         smb_tar('', '-Tcg', $TAR, $DIR);
 395     }
 396     return check_tar($TAR, \@files);
 397 }
 398
 399
 400 sub test_extraction_normal {
 401     my @files;
 402     my $n = 5;
 403     for (1..$n) {
 404         my $f = File->new_remote("file-$_");
 405         push @files, $f;
 406     }
 407
 408     # store
 409     smb_tar('', '-Tc', $TAR, $DIR);
 410     my $err = check_tar($TAR, \@files);
 411     return $err if $err > 0;
 412
 413     reset_remote();
 414
 415     smb_tar('', '-Tx', $TAR);
 416     check_remote($DIR, \@files);
 417 }
 418
 419 sub test_extraction_include {
 420     my @all_files;
 421     my @inc_files;
 422
 423     for (qw(file_inc inc/b inc/c inc/dir/foo dir_ex/d zob)) {
 424         my $f = File->new_remote($_);
 425         push @all_files, $f;
 426         push @inc_files, $f if /inc/;
 427     }
 428
 429     # store
 430     smb_tar('', '-Tc', $TAR, $DIR);
 431     my $err = check_tar($TAR, \@all_files);
 432     return $err if $err > 0;
 433
 434     reset_remote();
 435
 436     smb_tar('', '-TxI', $TAR, "$DIR/file_inc", "$DIR/inc");
 437     check_remote($DIR, \@inc_files);
 438 }
 439
 440 sub test_extraction_exclude {
 441     my @all_files;
 442     my @inc_files;
 443
 444     for (qw(file_exc exc/b exc/c exc/dir/foo dir_ex/d zob)) {
 445         my $f = File->new_remote($_);
 446         push @all_files, $f;
 447         push @inc_files, $f if !/exc/;
 448     }
 449
 450     # store
 451     smb_tar('', '-Tc', $TAR, $DIR);
 452     my $err = check_tar($TAR, \@all_files);
 453     return $err if $err > 0;
 454
 455     reset_remote();
 456
 457     smb_tar('', '-TxX', $TAR, "$DIR/file_exc", "$DIR/exc");
 458     check_remote($DIR, \@inc_files);
 459 }
 460
 461
 462 sub test_creation_include {
 463     my @files;
 464
 465     for (qw(file_inc inc/b inc/c inc/dir/foo dir_ex/d zob)) {
 466         my $f = File->new_remote($_);
 467         push @files, $f if /inc/;
 468     }
 469
 470     smb_tar('', '-TcI', $TAR, "$DIR/file_inc", "$DIR/inc");
 471     return check_tar($TAR, \@files);
 472 }
 473
 474 sub test_creation_exclude {
 475     my @files;
 476
 477     for (qw(file_ex ex/b ex/c ex/dir/foo foo/bar zob)) {
 478         my $f = File->new_remote($_);
 479         push @files, $f if !/ex/;
 480     }
 481
 482     smb_tar('', '-TcX', $TAR, "$DIR/file_ex", "$DIR/ex");
 483     return check_tar($TAR, \@files);
 484 }
 485
 486 sub test_creation_list {
 487     my @inc_files;
 488
 489     for (qw(file_inc inc/b inc/c inc/dir/foo foo/bar zob)) {
 490         my $f = File->new_remote($_);
 491         push @inc_files, $f if /inc/;
 492     }
 493
 494     my $flist = File->new_local("$TMP/list", file_list(@inc_files));
 495     smb_tar('', '-TcF', $TAR, $flist->localpath);
 496     return check_tar($TAR, \@inc_files);
 497 }
 498
 499 sub test_creation_regex {
 500     my @exts = qw(jpg exe);
 501     my @dirs = ('', "$DIR/");
 502     my @all = make_env(\@exts, \@dirs);
 503     my $nb;
 504     my @inc;
 505     my $err = 0;
 506
 507     # EXCLUSION
 508
 509     # skip *.exe
 510     @inc = grep { $_->remotepath !~ m{exe$} } @all;
 511     smb_tar('', '-TcrX', $TAR, '*.exe');
 512     $err += check_tar($TAR, \@inc);
 513
 514     # if the pattern is a path, it doesn't skip anything
 515     smb_tar('', '-TcrX', $TAR, "$DIR/*.exe");
 516     $err += check_tar($TAR, \@all);
 517     smb_tar('', '-TcrX', $TAR, "$DIR/*");
 518     $err += check_tar($TAR, \@all);
 519     smb_tar('', '-TcrX', $TAR, "$DIR");
 520     $err += check_tar($TAR, \@all);
 521
 522     # no paths => include everything
 523     smb_tar('', '-TcrX', $TAR);
 524     $err += check_tar($TAR, \@all);
 525
 526
 527     # skip everything
 528     smb_tar('', '-TcrX', $TAR, "*.*");
 529     $err += check_tar($TAR, []);
 530     smb_tar('', '-TcrX', $TAR, "*");
 531     $err += check_tar($TAR, []);
 532
 533     # INCLUSION
 534
 535     # no paths => include everything
 536     smb_tar('', '-Tcr', $TAR);
 537     $err += check_tar($TAR, \@all);
 538
 539     # include everything
 540     smb_tar('', '-Tcr', $TAR, '*');
 541     $err += check_tar($TAR, \@all);
 542
 543     # include only .exe at root
 544     @inc = grep { $_->remotepath =~ m{^[^/]+exe$}} @all;
 545     smb_tar('', '-Tcr', $TAR, '*.exe');
 546     $err += check_tar($TAR, \@inc);
 547
 548     # smb_tar('', '-Tcr', $TAR, "$DIR/*");
 549     ## in old version (bug?)
 550     # $err += check_tar($TAR, []);
 551     ## in rewrite
 552     # @inc = grep { $_->remotepath =~ /^$DIR/ } @all;
 553     # $err += check_tar($TAR, \@inc);
 554
 555     $err;
 556 }
 557
 558 sub test_creation_wildcard_simple {
 559     my @exts = qw(jpg exe);
 560     my @dirs = ('', "$DIR/");
 561     my @all = make_env(\@exts, \@dirs);
 562     my $nb;
 563     my @inc;
 564     my $err = 0;
 565
 566     @inc = grep { $_->remotepath =~ m{^[^/]+exe$} } @all;
 567     smb_tar('', '-Tc', $TAR, "*.exe");
 568     $err += check_tar($TAR, \@inc);
 569
 570     @inc = grep { $_->remotepath =~ m{$DIR/.+exe$} } @all;
 571     smb_tar('', '-Tc', $TAR, "$DIR/*.exe");
 572     $err += check_tar($TAR, \@inc);
 573
 574     $err;
 575 }
 576
 577 # NOT USED
 578 # helper to test tests
 579 sub test_helper {
 580     my @exts = qw(txt jpg exe);
 581     my @dirs = ('', "$DIR/", "$DIR/dir/");
 582     my @all = make_env(\@exts, \@dirs);
 583     my $nb;
 584     my $err = 0;
 585     my @inc;
 586
 587     smb_tar('', '-Tc', $TAR);
 588     return 1 if check_tar($TAR, \@all);
 589     reset_remote();
 590
 591     my @exc = grep { $_->remotepath =~ m!/dir/.+exe!} @all;
 592     @inc = grep { $_->remotepath !~ m!/dir/.+exe!} @all;
 593     smb_tar('', '-TxXr', $TAR, "/$DIR/dir/*.exe");
 594     $err += check_remote('/', \@all); # BUG: should be \@inc
 595     reset_remote();
 596
 597     return 0;
 598 }
 599
 600 sub test_creation_multiple {
 601     my @exts = qw(jpg exe);
 602     my @dirs = ('', "$DIR/");
 603     my @all = make_env(\@exts, \@dirs);
 604     my $nb;
 605     my @inc;
 606     my $err = 0;
 607
 608     my ($tarA, $tarB) = ("$TMP/a.tar", "$TMP/b.tar");
 609     my @incA = grep { $_->remotepath =~ m{^[^/]+exe$} } @all;
 610     my @incB = grep { $_->remotepath =~ m{^[^/]+jpg$} } @all;
 611
 612     my $flistA = File->new_local("$TMP/listA", file_list(@incA))->localpath;
 613     my $flistB = File->new_local("$TMP/listB", file_list(@incB))->localpath;
 614
 615     smb_tar("tar cF $tarA $flistA ; tar cF $tarB $flistB ; quit");
 616     $err += check_tar($tarA, \@incA);
 617     $err += check_tar($tarB, \@incB);
 618
 619     $err;
 620 }
 621
 622 sub test_extraction_regex {
 623     my @exts = qw(txt jpg exe);
 624     my @dirs = ('', "$DIR/", "$DIR/dir/");
 625     my @all = make_env(\@exts, \@dirs);
 626     my $nb;
 627     my $err = 0;
 628     my (@inc, @exc);
 629
 630     smb_tar('', '-Tc', $TAR);
 631     return 1 if check_tar($TAR, \@all);
 632     reset_remote();
 633
 634     # INCLUDE
 635
 636     # only include file at root
 637     @inc = grep { $_->remotepath =~ m!exe!} @all;
 638     smb_tar('', '-Txr', $TAR, "*.exe");
 639     $err += check_remote('/', \@inc);
 640     reset_remote();
 641
 642     @inc = grep { $_->remotepath =~ m!/dir/.+exe!} @all;
 643     smb_tar('', '-Txr', $TAR, "/$DIR/dir/*.exe");
 644     $err += check_remote('/', []); # BUG: should be \@inc
 645     reset_remote();
 646
 647     # EXCLUDE
 648
 649     # exclude file not directly at root
 650     @inc = grep { $_->remotepath =~ m!^[^/]+$!} @all;
 651     @exc = grep { $_->remotepath !~ m!^[^/]+$!} @all;
 652     smb_tar('', '-TxrX', $TAR, map {$_->remotepath} @exc);
 653     $err += check_remote('/', \@all); # BUG: should be @inc...
 654     reset_remote();
 655
 656     # exclude only $DIR/dir/*exe
 657     @exc = grep { $_->remotepath =~ m!/dir/.+exe!} @all;
 658     @inc = grep { $_->remotepath !~ m!/dir/.+exe!} @all;
 659     smb_tar('', '-TxXr', $TAR, "/$DIR/dir/*.exe");
 660     $err += check_remote('/', \@all); # BUG: should be \@inc
 661     reset_remote();
 662
 663     $err;
 664 }
 665
 666 sub test_extraction_wildcard {
 667     my @exts = qw(txt jpg exe);
 668     my @dirs = ('', "$DIR/", "$DIR/dir/");
 669     my $nb;
 670     my $err = 0;
 671
 672     for my $dir (@dirs) {
 673
 674         my @all;
 675
 676         $nb = 0;
 677         for my $dir (@dirs) {
 678             for (@exts) {
 679                 my $fn = $dir . "file$nb." . $_;
 680                 my $f = File->new_remote($fn, 'ABSPATH');
 681                 $f->delete_on_destruction(1);
 682                 push @all, $f;
 683                 $nb++;
 684             }
 685         }
 686
 687
 688         my @inc;
 689         my $ext = 'exe';
 690         my $fn = $dir."file$nb.".$ext;
 691         my $pattern = $dir.'*.'.$ext;
 692         my $flist;
 693
 694         # with F
 695
 696         $flist = File->new_local("$TMP/list", "$pattern\n");
 697
 698         # store
 699         my $re = '^'.$dir.'.*file';
 700         @inc = grep { $dir eq '' or $_->remotepath =~ m{$re} } @all;
 701         smb_tar('', '-Tc', $TAR, $dir);
 702         $err += check_tar($TAR, \@inc);
 703
 704         reset_remote();
 705         my $re2 = '^'.$dir.'file.+exe';
 706         @inc = grep { $_->remotepath =~ /$re2/ } @all;
 707         smb_tar('', '-TxrF', $TAR, $flist->localpath);
 708         $err += check_remote($dir, \@inc);
 709
 710         reset_remote();
 711     }
 712
 713     $err;
 714 }
 715
 716 sub test_extraction_list {
 717     my @inc_files;
 718     my @all_files;
 719
 720     for (qw(file_inc inc/b inc/c inc/dir/foo foo/bar zob)) {
 721         my $f = File->new_remote($_);
 722         push @all_files, $f;
 723         push @inc_files, $f if /inc/;
 724     }
 725
 726     # store
 727     smb_tar('', '-Tc', $TAR, $DIR);
 728     my $err = check_tar($TAR, \@all_files);
 729     return $err if $err > 0;
 730
 731     reset_remote();
 732
 733     my $flist = File->new_local("$TMP/list", file_list(@inc_files));
 734     smb_tar('', '-TxF', $TAR, $flist->localpath);
 735     return check_remote($DIR, \@inc_files);
 736 }
 737
 738 #################################
 739
 740 # IMPLEMENTATION
 741
 742 =head2 Useful functions
 743
 744 Here are a list of useful functions and helpers to define tests.
 745
 746 =cut
 747
 748 # list test number and description
 749 sub list_test {
 750     my $i = 0;
 751     for (@TESTS) {
 752         my ($desc, $f, @args) = @$_;
 753         printf "%2d.\t%s\n", $i++, $desc;
 754     }
 755 }
 756
 757 sub run_test {
 758     if ($SUBUNIT) {
 759         run_test_subunit(@_);
 760     } else {
 761         run_test_normal(@_);
 762     }
 763 }
 764
 765 sub run_test_normal {
 766     for (@_) {
 767         my ($desc, $f, @args) = @$_;
 768         my $err;
 769
 770         reset_env();
 771         say "TEST: $desc";
 772         if ($VERBOSE) {
 773             $err = $f->(@args);
 774         } else {
 775             # turn off STDOUT
 776             open my $saveout, ">&STDOUT";
 777             open STDOUT, '>', File::Spec->devnull();
 778             $err = $f->(@args);
 779             open STDOUT, ">&", $saveout;
 780         }
 781         print_res($err);
 782         print "\n";
 783     }
 784     reset_env();
 785 }
 786
 787 sub run_test_subunit {
 788     for (@_) {
 789         my ($desc, $f, @args) = @$_;
 790         my $err;
 791         my $str = '';
 792
 793         reset_env();
 794         say "test: $desc";
 795
 796         # capture output in $buf
 797         my $buf = '';
 798         open my $handle, '>', \$buf;
 799         select $handle;
 800
 801         # check for die() calls
 802         eval {
 803             $err = $f->(@args);
 804         };
 805         if ($@) {
 806             $str = $@;
 807             $err = 1;
 808         }
 809         close $handle;
 810
 811         # restore output
 812         select STDOUT;
 813
 814         # result string is output + eventual exception message
 815         $str = $buf.$str;
 816
 817         printf "%s: %s [\n%s]\n", ($err > 0 ? "failure" : "success"), $desc, $str;
 818     }
 819     reset_env();
 820 }
 821
 822 sub parse_test_string {
 823     my $s = shift;
 824     my @tests = ();
 825
 826     if (!length($s)) {
 827         return ();
 828     }
 829
 830     for (split /,/, $s) {
 831         when (/^\d+$/) {
 832             if ($_ >= @TESTS) {
 833                 return ();
 834             }
 835             push @tests, $TESTS[$_];
 836         }
 837         when (/^(\d+)-(\d+)$/) {
 838             my ($min, $max) = sort ($1, $2);
 839             if ($max >= @TESTS) {
 840                 return ();
 841             }
 842
 843             for ($min..$max) {
 844                 push @tests, $TESTS[$_];
 845             }
 846         }
 847         default {
 848             return ();
 849         }
 850     }
 851
 852     return @tests;
 853 }
 854
 855 sub print_res {
 856     my $err = shift;
 857     if ($err) {
 858         printf " RES: %s%d ERR%s\n", color('bold red'), $err, color 'reset';
 859     } else {
 860         printf " RES: %sOK%s\n", color('bold green'), color 'reset';
 861     }
 862 }
 863
 864 sub make_env {
 865     my ($exts, $dirs) = @_;
 866     my @all;
 867     my $nb = 0;
 868     for my $dir (@$dirs) {
 869         for (@$exts) {
 870             my $fn = $dir . "file$nb." . $_;
 871             my $f = File->new_remote($fn, 'ABSPATH');
 872             $f->delete_on_destruction(1);
 873             push @all, $f;
 874             $nb++;
 875         }
 876     }
 877
 878     @all;
 879 }
 880
 881 =head3 C<combine ( \@set, $n )>
 882
 883 =head3 C<combine ( ['a', 'b', 'c'], 2 )>
 884
 885 Return a list of all possible I<n>-uplet (or combination of C<$n> element) of C<@set>.
 886
 887 =cut
 888 sub combine {
 889     my ($list, $n) = @_;
 890     die "Insufficient list members" if $n > @$list;
 891
 892     return map [$_], @$list if $n <= 1;
 893
 894     my @comb;
 895
 896     for (my $i = 0; $i+$n <= @$list; $i++) {
 897         my $val = $list->[$i];
 898         my @rest = @$list[$i+1..$#$list];
 899         push @comb, [$val, @$_] for combine(\@rest, $n-1);
 900     }
 901
 902     return @comb;
 903 }
 904
 905
 906 =head3 C<reset_remote( )>
 907
 908 Remove all files in the server C<$DIR> (not root)
 909
 910 =cut
 911 sub reset_remote {
 912     # remove_tree($LOCALPATH . '/'. $DIR);
 913     # make_path($LOCALPATH . '/'. $DIR);
 914     remove_tree($LOCALPATH, {keep_root => 1});
 915     make_path($LOCALPATH, {keep_root => 1});
 916 }
 917
 918 =head3 C<reset_tmp( )>
 919
 920 Remove all files in the temp directory C<$TMP>
 921
 922 =cut
 923 sub reset_tmp {
 924     remove_tree($TMP, { keep_root => 1 });
 925 }
 926
 927
 928 =head3 C<reset_env( )>
 929
 930 Remove both temp and remote (C<$DIR>) files
 931
 932 =cut
 933 sub reset_env {
 934     reset_tmp();
 935     reset_remote();
 936 }
 937
 938 =head3 C<file_list ( @files )>
 939
 940 Make a multiline string of all the files remote path, one path per line.
 941
 942 C<@files> must be a list of C<File> instance.
 943
 944 =cut
 945 sub file_list {
 946     my @files = @_;
 947     my $s = '';
 948     for (@files) {
 949         $s .= $_->remotepath."\n";
 950     }
 951     return $s;
 952 }
 953
 954 =head3 C<check_remote( $remotepath, \@files )>
 955
 956 Check if C<$remotepath> has B<exactly> all the C<@files>.
 957
 958 Print a summary on STDOUT.
 959
 960 C<@files> must be a list of C<File> instance.
 961
 962 =cut
 963 sub check_remote {
 964     my ($subpath, $files) = @_;
 965     my (%done, %expected);
 966     my (@less, @more, @diff);
 967
 968     for (@$files) {
 969         $expected{$_->remotepath} = $_;
 970         $done{$_->remotepath} = 0;
 971     }
 972
 973     my %remote;
 974     File::walk(sub { $remote{$_->remotepath} = $_ }, File::tree($subpath));
 975
 976     for my $rfile (sort keys %remote) {
 977
 978         # files that shouldn't be there
 979         if (!exists $expected{$rfile}) {
 980             say " +    $rfile";
 981             push @more, $rfile;
 982             next;
 983         }
 984
 985         # same file multiple times
 986         if ($done{$rfile} > 0) {
 987             $done{$rfile}++;
 988             push @more, $rfile;
 989             printf " +%3d %s\n", $done{$rfile}, $rfile;
 990             next;
 991         }
 992
 993         $done{$rfile}++;
 994
 995         # different file
 996         my $rmd5 = $remote{$rfile}->md5;
 997         if ($expected{$rfile}->md5 ne $rmd5) {
 998             say " !    $rfile ($rmd5)";
 999             push @diff, $rfile;
1000             next;
1001         }
1002
1003         say "      $rfile";
1004     }
1005
1006     # file that should have been in tar
1007     @less = grep { $done{$_} == 0 } sort keys %done;
1008     for (@less) {
1009         say " -    $_";
1010     }
1011
1012     # summary
1013     printf("\t%d files, +%d, -%d, !%d\n",
1014            scalar keys %done,
1015            scalar @more,
1016            scalar @less,
1017            scalar @diff);
1018     return (@more + @less + @diff); # nb of errors
1019 }
1020
1021 =head3 C<check_tar( $path_to_tar, \@files )>
1022
1023 Check if the archive C<$path_to_tar> has B<exactly> all the C<@files>.
1024
1025 Print a summary on C<STDOUT>;
1026
1027 C<@files> must be a list of C<File> instance.
1028
1029 =cut
1030 sub check_tar {
1031     my ($tar, $files) = @_;
1032     my %done;
1033     my (@less, @more, @diff);
1034
1035     my %h;
1036
1037
1038     if (!-f $tar) {
1039         say "no tar file $tar";
1040         return 1;
1041     }
1042
1043     for (@$files) {
1044         $h{$_->tarpath} = $_;
1045         $done{$_->tarpath} = 0;
1046     }
1047
1048     my $total = 0;
1049     my $i = Archive::Tar->iter($tar, 1, {md5 => 1});
1050     while (my $f = $i->()) {
1051         if ($f->has_content) {
1052             $total++;
1053             my $p = $f->full_path =~ s{^\./+}{}r;
1054
1055             # file that shouldn't be there
1056             if (!exists $done{$p}) {
1057                 push @more, $p;
1058                 say " +    $p";
1059                 next;
1060             }
1061
1062             # same file multiple times
1063             if ($done{$p} > 0) {
1064                 $done{$p}++;
1065                 push @more, $p;
1066                 printf " +%3d %s\n", $done{$p}, $p;
1067                 next;
1068             }
1069
1070             $done{$p}++;
1071
1072             # different file
1073
1074             my $md5 = $f->data;
1075             if ($^V lt v5.16) {
1076                 $md5 = md5_hex($md5);
1077             }
1078
1079             if ($md5 ne $h{$p}->md5) {
1080                 say " !    $p ($md5)";
1081                 push @diff, $p;
1082                 next;
1083             }
1084
1085             say "      $p";
1086         }
1087     }
1088
1089     # file that should have been in tar
1090     @less = grep { $done{$_} == 0 } keys %done;
1091     for (sort @less) {
1092         say " -    $_";
1093     }
1094
1095     # summary
1096     printf("\t%d files, +%d, -%d, !%d\n",
1097            $total,
1098            scalar @more,
1099            scalar @less,
1100            scalar @diff);
1101     return (@more + @less + @diff); # nb of errors
1102 }
1103
1104 =head3 C<smb_client ( @args )>
1105
1106 Run smbclient with C<@args> passed as argument and return output.
1107
1108 Each element of C<@args> becomes one escaped argument of smbclient.
1109
1110 Host, share, user, password and the additionnal arguments provided on
1111 the command-line are already inserted.
1112
1113 The output contains both the C<STDOUT> and C<STDERR>.
1114
1115 Die if smbclient crashes or exits with an error code.
1116
1117 =cut
1118 sub smb_client {
1119     my (@args) = @_;
1120
1121     my $fullpath = "//$HOST/$SHARE";
1122     my $cmd = sprintf("%s %s %s",
1123                       quotemeta($BIN),
1124                       quotemeta($fullpath),
1125                       join(' ', map {quotemeta} (@SMBARGS, @args)));
1126
1127     if ($DEBUG) {
1128         say color('bold yellow'),$cmd =~ s{\\([./+-])}{$1}gr,color('reset');
1129     }
1130
1131     my $out = `$cmd 2>&1`;
1132     my $err = $?;
1133     my $errstr = '';
1134     # handle abnormal exit
1135     if ($err == -1) {
1136         $errstr = "failed to execute $cmd: $!\n";
1137     }
1138     elsif ($err & 127) {
1139         $errstr = sprintf "child died with signal %d (%s)\n", ($err & 127), $cmd;
1140     }
1141     elsif ($err >> 8) {
1142         $errstr = sprintf "child exited with value %d (%s)\n", ($err >> 8), $cmd;
1143     }
1144
1145     if ($DEBUG) {
1146         say $out;
1147     }
1148
1149     if ($err) {
1150         die "ERROR: $errstr";
1151     }
1152     return $out;
1153 }
1154
1155 sub smb_cmd {
1156     return smb_client('-c', join(' ', @_));
1157 }
1158
1159 =head3 C<smb_tar( $cmd, @args )>
1160
1161 =head3 C<smb_tar( 'tarmode inc', '-Tc', $TAR, $DIR )>
1162
1163 Run C<$cmd> command and use C<@args> as argument and return output.
1164
1165 Wrapper around C<smb_client> for tar calls.
1166
1167 =cut
1168 sub smb_tar {
1169     my ($cmd, @rest) = @_;
1170     printf " CMD: %s\n ARG: %s\n", $cmd, join(' ', @rest);
1171     smb_client((length($cmd) ? ('-c', $cmd) : ()), @rest);
1172 }
1173
1174 =head3 C<random( $min, $max )>
1175
1176 Return integer in C<[ $min ; $max ]>
1177
1178 =cut
1179 sub random {
1180     my ($min, $max) = @_;
1181     ($min, $max) = ($max, $min) if ($min > $max);
1182     $min + int(rand($max - $min));
1183 }
1184
1185 #################################
1186
1187 package File;
1188
1189 =head2 The File module
1190
1191 All the test should use the C<File> class. It has nice functions and
1192 methods to deal with paths, to create random files, to list the
1193 content of the server, to change attributes, etc.
1194
1195 There are 2 kinds of C<File>: remote and local.
1196
1197 =over
1198
1199 =item * Remote files are accessible on the server.
1200
1201 =item * Local files are not.
1202
1203 =back
1204
1205 Thus, some methods only works on remote files. If they do not make
1206 sense for local ones, they always return undef.
1207
1208 =cut
1209 use File::Basename;
1210 use File::Path qw/make_path remove_tree/;
1211 use Digest::MD5 qw/md5_hex/;
1212 use Scalar::Util 'blessed';
1213
1214 =head3 Constructors
1215
1216 =head4 C<< File->new_remote($path [, $abs, $size]) >>
1217
1218 Creates a file accessible on the server at C<$DIR/$path> ie. not at the
1219 root of the share and write C<$size> random bytes.
1220
1221 If no size is provided, a random size is chosen.
1222
1223 If you want to remove the automatic prefix C<$DIR>, set C<$abs> to 1.
1224
1225 The file is created without any DOS attributes.
1226
1227 If C<$path> contains non-existent directories, they are automatically
1228 created.
1229
1230 =cut
1231 sub new_remote {
1232     my ($class, $path, $abs, $size) = @_;
1233     my ($file, $dir) = fileparse($path);
1234
1235     $dir = '' if $dir eq './';
1236     my $loc;
1237
1238     if ($abs) {
1239         $loc = cleanpath($main::LOCALPATH.'/'.$dir);
1240     } else {
1241         $dir = cleanpath($main::DIR.'/'.$dir);
1242         $loc = cleanpath($main::LOCALPATH.'/'.$dir);
1243     }
1244
1245     make_path($loc);
1246
1247     my $self = bless {
1248         'attr' => {qw/r 0 s 0 h 0 a 0 d 0 n 0/},
1249         'dir'  => $dir,
1250         'name' => $file,
1251         'md5'  => create_file($loc.'/'.$file, $size),
1252         'remote' => 1,
1253     }, $class;
1254
1255     $self->set_attr();
1256
1257     $self;
1258 }
1259
1260 =head4 C<< File->new_local($abs_path [, $data]) >>
1261
1262 Creates a file at C<$abs_path> with $data in it on the system.
1263 If $data is not provided, fill it with random bytes.
1264
1265 =cut
1266 sub new_local {
1267     my ($class, $path, $data) = @_;
1268     my ($file, $dir) = fileparse($path);
1269
1270     make_path($dir);
1271
1272     my $md5;
1273
1274     if (defined $data) {
1275         open my $f, '>', $path or die "can't write in $path: $!";
1276         print $f $data;
1277         close $f;
1278         $md5 = md5_hex($data);
1279     } else {
1280         $md5 = create_file($path);
1281     }
1282
1283     my $self = {
1284         'attr' => {qw/r 0 s 0 h 0 a 0 d 0 n 0/},
1285         'dir'  => $dir,
1286         'name' => $file,
1287         'md5'  => $md5,
1288         'remote' => 0,
1289     };
1290
1291     bless $self, $class;
1292 }
1293
1294 =head3 Methods
1295
1296 =head4 C<< $f->localpath >>
1297
1298 Return path on the system eg. F</opt/samba/share/test_tar_mode/file>
1299
1300 =cut
1301 sub localpath {
1302     my $s = shift;
1303     if ($s->{remote}) {
1304         return cleanpath($main::LOCALPATH.'/'.$s->remotepath);
1305     }
1306     else {
1307         return cleanpath($s->{dir}.'/'.$s->{name});
1308     }
1309 }
1310
1311 =head4 C<< $f->remotepath >>
1312
1313 Return path on the server share.
1314
1315 Return C<undef> if the file is local.
1316
1317 =cut
1318 sub remotepath {
1319     my ($s) = @_;
1320     return undef if !$s->{remote};
1321     cleanpath(($s->{dir}.'/'.$s->{name}) =~ s{^/}{}r);
1322 }
1323
1324
1325 =head4 C<< $f->remotedir >>
1326
1327 Return the directory path of the file on the server.
1328
1329 Like C<< $f->remotepath >> but without the final file name.
1330
1331 =cut
1332 sub remotedir {
1333     my $s = shift;
1334     return undef if !$s->{remote};
1335     cleanpath($s->{dir});
1336 }
1337
1338 =head4 C<< $f->tarpath >>
1339
1340 Return path as it would appear in a tar archive.
1341
1342 Like C<< $f->remotepath >> but prefixed with F<./>
1343
1344 =cut
1345 sub tarpath {
1346     my $s = shift;
1347     return undef if !$s->{remote};
1348     $s->remotepath =~ s{^\./+}{}r;
1349 }
1350
1351 =head4 C<< $f->delete_on_destruction( 0 ) >>
1352
1353 =head4 C<< $f->delete_on_destruction( 1 ) >>
1354
1355 By default, a C<File> is not deleted on the filesystem when it is not
1356 referenced anymore in Perl memory.
1357
1358 When set to 1, the destructor unlink the file if it is not already removed.
1359 If the C<File> created directories when constructed, it does not remove them.
1360
1361 =cut
1362 sub delete_on_destruction {
1363     my ($s, $delete) = @_;
1364     $s->{delete_on_destruction} = $delete;
1365 }
1366
1367 =head4 C<< $f->set_attr( ) >>
1368
1369 =head4 C<< $f->set_attr( 'a' ) >>
1370
1371 =head4 C<< $f->set_attr( 'a', 'r', 's', 'h' ) >>
1372
1373 Remove all DOS attributes and only set the one provided.
1374
1375 =cut
1376 sub set_attr {
1377     my ($s, @flags) = @_;
1378     return undef if !$s->{remote};
1379
1380     $s->{attr} = {qw/r 0 s 0 h 0 a 0 d 0 n 0/};
1381
1382     for (@flags) {
1383         $s->{attr}{lc($_)} = 1;
1384     }
1385
1386     my $file = $s->{name};
1387     my @args;
1388     if ($s->remotedir) {
1389         push @args, '-D', $s->remotedir;
1390     }
1391     main::smb_client(@args, '-c', qq{setmode "$file" -rsha});
1392     if (@flags && $flags[0] !~ /n/i) {
1393         main::smb_client(@args, '-c', qq{setmode "$file" +}.join('', @flags));
1394     }
1395 }
1396
1397 =head4 C<< $f->attr_any( 'a' ) >>
1398
1399 =head4 C<< $f->attr_any( 'a', 's', ... ) >>
1400
1401 Return 1 if the file has any of the DOS attributes provided.
1402
1403 =cut
1404 sub attr_any {
1405     my ($s, @flags) = @_;
1406     for (@flags) {
1407         return 1 if $s->{attr}{$_};
1408     }
1409     0;
1410 }
1411
1412
1413 =head4 C<< $f->attr( 'a' ) >>
1414
1415 =head4 C<< $f->attr( 'a', 's', ... ) >>
1416
1417 Return 1 if the file has all the DOS attributes provided.
1418
1419 =cut
1420 sub attr {
1421     my ($s, @flags) = @_;
1422     for (@flags) {
1423         return 0 if !$s->{attr}{$_};
1424     }
1425     1;
1426 }
1427
1428 =head4 C<< $f->attr_str >>
1429
1430 Return DOS attributes as a compact string.
1431
1432   Read-only, hiden, system, archive => "rhsa"
1433
1434 =cut
1435 sub attr_str {
1436     my $s = shift;
1437     return undef if !$s->{remote};
1438     join('', map {$_ if $s->{attr}{$_}} qw/r h s a d n/);
1439 }
1440
1441 =head4 C<< $f->set_time($t) >>
1442
1443 Set modification and access time of the file to C<$t>.
1444
1445 C<$t> must be in Epoch time (number of seconds since 1970/1/1).
1446
1447 =cut
1448 sub set_time {
1449     my ($s, $t) = @_;
1450     utime $t, $t, $s->localpath;
1451 }
1452
1453 =head4 C<< $f->md5 >>
1454
1455 Return md5 sum of the file.
1456
1457 The result is cached.
1458
1459 =cut
1460 sub md5 {
1461     my $s = shift;
1462
1463     if (!$s->{md5}) {
1464         open my $h, '<', $s->localpath() or die "can't read ".$s->localpath.": $!";
1465         binmode $h;
1466         $s->{md5} = Digest::MD5->new->addfile($h)->hexdigest;
1467         close $h;
1468     }
1469
1470     return $s->{md5};
1471 }
1472
1473 sub DESTROY {
1474     my $s = shift;
1475     if ($s->{delete_on_destruction} && -f $s->localpath) {
1476         if ($main::DEBUG) {
1477             say "DESTROY ".$s->localpath;
1478         }
1479         unlink $s->localpath;
1480     }
1481 }
1482
1483 =head3 Functions
1484
1485 =head4 C<< File::walk( \&function, @files) >>
1486
1487 =head4 C<< File::walk( sub { ... }, @files) >>
1488
1489 Iterate on file hierachy in C<@files> and return accumulated results.
1490
1491 Use C<$_> in the sub to access the current C<File>.
1492
1493 The C<@files> must come from a call to the C<File::tree> function.
1494
1495 =cut
1496 sub walk {
1497     my $fun = \&{shift @_};
1498
1499     my @res;
1500
1501     for (@_) {
1502         if ($_->{attr}{d}) {
1503             push @res, walk($fun, @{$_->{content}});
1504         } else {
1505             push @res, $fun->($_);
1506         }
1507     }
1508
1509     return @res;
1510 }
1511
1512 =head4 C<< File::list( $remotepath ) >>
1513
1514 Return list of file (C<File> instance) in C<$remotepath>.
1515
1516 C<$remotepath> must be a directory.
1517
1518 =cut
1519 sub list {
1520     my ($path) = @_;
1521     $path ||= '/';
1522     my @files;
1523     my $out = main::smb_client('-D', $path, '-c', 'ls');
1524
1525     for (split /\n/, $out) {
1526         next if !/^  (.+?)\s+([AHSRDN]*)\s+(\d+)\s+(.+)/o;
1527         my ($fn, $attr, $size, $date) = ($1, $2, $3, $4);
1528         next if $fn =~ /^\.{1,2}$/;
1529
1530         push @files, bless {
1531             'remote' => 1,
1532             'dir'    => $path =~ s{^/}{}r,
1533             'name'   => $fn,
1534             'size'   => int($size),
1535             'date'   => $date,
1536             'attr'   => {
1537                 # list context returns something different than the
1538                 # boolean matching result => force scalar context
1539                 'a' => scalar ($attr =~ /A/),
1540                 'h' => scalar ($attr =~ /H/),
1541                 's' => scalar ($attr =~ /S/),
1542                 'r' => scalar ($attr =~ /R/),
1543                 'd' => scalar ($attr =~ /D/),
1544                 'n' => scalar ($attr =~ /N/),
1545             },
1546         }, 'File';
1547     }
1548     return @files;
1549 }
1550
1551 =head4 C<< File::tree( $remotepath ) >>
1552
1553 Return recursive list of file in C<$remotepath>.
1554
1555 C<$remotepath> must be a directory.
1556
1557 Use C<File::walk()> to iterate over all the files.
1558
1559 =cut
1560 sub tree {
1561     my ($d) = @_;
1562     my @files;
1563
1564     if (!defined $d) {
1565         @files = list();
1566     } elsif (blessed $d) {
1567         @files = list($d->remotepath);
1568     } else {
1569         @files = list($d);
1570     }
1571
1572     for my $f (@files) {
1573         if ($f->{attr}{d}) {
1574             $f->{content} = [tree($f)];
1575         }
1576     }
1577
1578     return @files;
1579 }
1580
1581 # remove trailing or duplicated slash
1582 sub cleanpath {
1583     my $p = shift;
1584     $p =~ s{/+}{/}g;
1585     $p =~ s{/$}{};
1586     $p;
1587 }
1588
1589 # create random file at path local path $fn
1590 sub create_file {
1591     my ($fn, $size) = @_;
1592     my $buf = '';
1593     unlink $fn if -e $fn;
1594     $size ||= main::random(512, 1024);
1595     $size = int($size);
1596     my $md5;
1597
1598     # try /dev/urandom, faster
1599     if (-e '/dev/urandom') {
1600         my $cmd = sprintf('head -c %d /dev/urandom | tee %s | md5sum',
1601                           $size, quotemeta($fn));
1602         $md5 = (split / /, `$cmd`)[0];
1603     } else {
1604         open my $out, '>', $fn or die "can't open $fn: $!\n";
1605         binmode $out;
1606         for (1..$size) {
1607             $buf .= pack('C', main::random(0, 256));
1608         }
1609         print $out $buf;
1610         close $out;
1611         $md5 = md5_hex($buf);
1612     }
1613     return $md5;
1614 }
1615
1616
1617 =head3 Examples
1618
1619     # create remote file in $DIR/foo/bar
1620         my $f = File->new_remote("foo/bar/myfile");
1621         say $f->localpath;  # /opt/share/$DIR/foo/bar/myfile
1622         say $f->remotepath; # $DIR/foo/bar/myfile
1623         say $f->remotedir;  # $DIR/foo/bar
1624
1625
1626     # same but in root dir
1627         my $f = File->new_remote("myfile", 1);
1628         say $f->localpath;  # /opt/share/myfile
1629         say $f->remotepath; # myfile
1630         say $f->remotedir;  #
1631
1632
1633     # create local random temp file in $TMP
1634         my $f = File->new_local("$TMP/temp");
1635         say $f->remotepath; # undef because it's not on the server
1636
1637
1638     # same but file contains "hello"
1639         my $f = File->new_local("$TMP/temp", "hello");
1640
1641
1642     # list of files in $DIR (1 level)
1643         for (File::list($DIR)) {
1644             say $_->remotepath;
1645         }
1646
1647
1648     # list of all files in dir and subdir of $DIR
1649         File::walk(sub { say $_->remotepath }, File::tree($DIR));
1650
1651 =cut
1652
1653 1;