File: Helper.pm

package info (click to toggle)
libfile-copy-recursive-reduced-perl 0.008-1
  • links: PTS, VCS
  • area: main
  • in suites: forky, sid, trixie
  • size: 192 kB
  • sloc: perl: 408; makefile: 2
file content (259 lines) | stat: -rw-r--r-- 8,117 bytes parent folder | download | duplicates (4)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
package Helper;
use strict;
use warnings;

our (@EXPORT_OK, @ISA);
use Exporter ();
@ISA = 'Exporter';
@EXPORT_OK = ( qw|
    create_tfile
    create_tfile_and_name_for_new_file_in_same_dir
    get_mode
    create_tsubdir
    get_fresh_tmp_dir
    touch_a_file_and_test
    touch_directories_and_test
    touch_left_path_and_test
    prepare_left_side_directories
    make_mixed_directory
    make_imperfect_mixed_directory
| );
use File::Basename ( qw| basename dirname | );
use File::Path ( qw| mkpath | );
use File::Spec;
use File::Temp ( qw| tempdir | );
use Path::Tiny;

sub create_tfile {
    my $tdir = shift;
    my $filename = shift || 'old';
    my $f = File::Spec->catfile($tdir, $filename);
    open my $OUT, '>', $f or die "Unable to open for writing: $!";
    binmode $OUT;
    print $OUT "\n";
    close $OUT or die "Unable to close after writing: $!";
    return $f;
}

sub create_tfile_and_name_for_new_file_in_same_dir {
    my $tdir = shift;
    my $new_filename = shift || 'new_file';
    my $old = create_tfile($tdir);
    my $new = File::Spec->catfile($tdir, $new_filename);
    return ($old, $new);
}

sub get_mode {
    my $file = shift;
    return sprintf("%04o" => ((stat($file))[2] & 07777));
}

sub create_tsubdir {
    my $tdir = shift;
    my $old = File::Spec->catdir($tdir, 'old_dir');
    my $rv = mkdir($old);
    die "Unable to create temporary subdirectory for testing: $!"
        unless $rv;
    return $old;
}

sub get_fresh_tmp_dir {
    # Adapted from FCR t/01.legacy.t
    my $tmpd = shift || tempdir( CLEANUP => 1 );
    for my $dir ( _get_dirs($tmpd) ) {
        my @created = mkpath($dir, { mode => 0711 });
        die "Unable to create directory $dir for testing: $!" unless @created;

        path("$dir/empty")->spew("");
        path("$dir/data")->spew("oh hai\n$dir");
        path("$dir/data_tnl")->spew("oh hai\n$dir\n");
        no warnings 'once';
        if ($File::Copy::Recursive::Reduced::CopyLink) {
            symlink( "data",    "$dir/symlink" );
            symlink( "noexist", "$dir/symlink-broken" );
            symlink( "..",      "$dir/symlink-loopy" );
        }
        use warnings;
    }
    return $tmpd;
}

sub _get_dirs {
    # Adapted from FCR t/01.legacy.t
    my $tempd = shift;
    my @dirs = (
        [ qw| orig | ],
        [ qw| orig foo | ],
        [ qw| orig foo bar | ],
        [ qw| orig foo baz | ],
        [ qw| orig foo bar bletch | ],
    );
    my @catdirs = ();
    for my $set (@dirs) {
        push @catdirs, File::Spec->catdir($tempd, @{$set});
    }
    return @catdirs;
}

sub touch_a_file_and_test {
    my $f = shift;
    open my $OUT, '>', $f or die "Unable to open $f for writing";
    print $OUT "\n";
    close $OUT or die "Unable to close $f after writing";
    Test::More::ok(-f $f, "Created $f for testing");
    return 1;
}

sub touch_directories_and_test {
    my ($topdir, $tdir_names) = @_;
    my @tdirs = ();
    for my $d (@{$tdir_names}) {
        my $s = File::Spec->catdir($topdir, $d);
        mkpath($s) or die "Unable to mkpath $s: $!";
        Test::More::ok(-d $s, "Directory $s created");
        push @tdirs, $s;
    }
    return @tdirs;
}

sub touch_left_path_and_test {
    my @dirs = @_;
    my $ldir = File::Spec->catdir(@dirs);
    mkpath($ldir) or die "Unable to mkpath $ldir: $!";
    Test::More::ok(-d $ldir, "Directory $ldir created");
    return $ldir;
}

sub prepare_left_side_directories {
    my ($topdir, $dirname, $subdirs) = @_;
    my $tdir = File::Spec->catdir($topdir, $dirname);
    mkpath($tdir) or die "Unable to mkpath $tdir";
    Test::More::ok(-d $tdir, "Directory $tdir created");
    my $old        = File::Spec->catdir($tdir);
    my $oldtree    = File::Spec->catdir($tdir, @{$subdirs});
    my @created = mkpath($oldtree, { mode => 0711 });
    die "Unable to create directory $oldtree for testing: $!" unless -d $oldtree;
    Test::More::ok(-d $oldtree, "Directory $oldtree created for testing");
    return ($old, $oldtree);
}

sub make_mixed_directory {
    my $topdir = shift;
    my @dirnames = qw( alpha beta gamma );
    my @subdirs = ();
    for my $d (@dirnames) {
        my $p = File::Spec->catdir($topdir, $d);
        mkpath $p or die "Unable to mkpath $p";
        push @subdirs, $p;
    }
    my @next_dirnames = qw( albemarle beverly );
    my @nextdirs = ();
    my @files_created = ();
    for my $d (@subdirs) {
        for my $e (@next_dirnames) {
            my $p = File::Spec->catdir($d, $e);
            mkpath $p or die "Unable to mkpath $p";
            push @nextdirs, $p;
            my @fnames = qw( f1 f2 );
            if ($e eq $next_dirnames[0]) {
                my $f1 = File::Spec->catfile($p, $fnames[0]);
                my $f2 = File::Spec->catfile($p, $fnames[1]);
                for my $f ($f1, $f2) {
                    open my $OUT, '>', $f or die "Unable to open for writing";
                    print $OUT "\n";
                    close $OUT or die "Unable to close after writing";
                    push @files_created, $f;
                }
            }
        }
    }
    my @symlinks_created = ();
    for my $f (@files_created) {
        my $base = basename($f);
        my $dirs = dirname($f);
        if ($base eq 'f1') {
            my @dirs = File::Spec->splitdir($dirs);
            my $orig = File::Spec->catfile($f);
            my $newdir = File::Spec->catdir(@dirs[0 .. ($#dirs -1)], 'beverly');
            my $symlink = File::Spec->catfile($newdir, 'l1');
            symlink $orig, $symlink or die "Unable to symlink";
            push @symlinks_created, $symlink;
        }

    }
    my @dirs_created = (@subdirs, @nextdirs);
    my $rv = {
        dirs => \@dirs_created,
        files => \@files_created,
        symlinks => \@symlinks_created,
    };
    #require Data::Dump;
    #Data::Dump::dd($rv);
    return $rv;
}

sub make_imperfect_mixed_directory {
    my $topdir = shift;
    my @dirnames = qw( alpha beta gamma );
    my @subdirs = ();
    for my $d (@dirnames) {
        my $p = File::Spec->catdir($topdir, $d);
        mkpath $p or die "Unable to mkpath $p";
        push @subdirs, $p;
    }
    my @next_dirnames = qw( albemarle beverly );
    my @nextdirs = ();
    my %files_created = ();
    for my $d (@subdirs) {
        for my $e (@next_dirnames) {
            my $p = File::Spec->catdir($d, $e);
            mkpath $p or die "Unable to mkpath $p";
            push @nextdirs, $p;
            my @fnames = qw( f1 f2 );
            if ($e eq $next_dirnames[0]) {
                my $f1 = File::Spec->catfile($p, $fnames[0]);
                my $f2 = File::Spec->catfile($p, $fnames[1]);
                for my $f ($f1, $f2) {
                    open my $OUT, '>', $f or die "Unable to open for writing";
                    print $OUT "\n";
                    close $OUT or die "Unable to close after writing";
                    #push @files_created, $f;
                    $files_created{$f}++;
                }
            }
        }
    }
    my @symlinks_created = ();
    for my $f (keys %files_created) {
        my $base = basename($f);
        my $dirs = dirname($f);
        if ($base eq 'f1') {
            my @dirs = File::Spec->splitdir($dirs);
            my $orig = File::Spec->catfile($f);
            my $newdir = File::Spec->catdir(@dirs[0 .. ($#dirs -1)], 'beverly');
            my $symlink = File::Spec->catfile($newdir, 'l1');
            symlink $orig, $symlink or die "Unable to symlink";
            push @symlinks_created, $symlink;
        }

    }
    # delete 1 file which is the target of a symlink
    # "/tmp/Gi_iWAqYXz/old/alpha/albemarle/f1"
    for my $f (keys %files_created) {
        my $g = File::Spec->catfile($topdir, $dirnames[0], $next_dirnames[0], 'f1');
        if ($f =~ m{\Q$g\E$}) {
            unlink $g or die "Unable to unlink $g";
            delete $files_created{$f};
            last;
        }
    }
    my @dirs_created = (@subdirs, @nextdirs);
    my $rv = {
        dirs => \@dirs_created,
        files => [ keys %files_created ],
        symlinks => \@symlinks_created,
    };
    return $rv;
}

1;