1 #!/usr/bin/perl
 2 # https://theweeklychallenge.org/blog/perl-weekly-challenge-203/#TASK2
 3 # Task 2: Copy Directory
 4 #
 5 # You are given path to two folders, $source and $target.
 6 #
 7 # Write a script that recursively copy the directory from $source to $target except any files.
 8 #
 9 ## Example
10 ##
11 ## Input: $source = '/a/b/c' and $target = '/x/y'
12 ##
13 ## Source directory structure:
14 ##
15 ## ├── a
16 ## │   └── b
17 ## │       └── c
18 ## │           ├── 1
19 ## │           │   └── 1.txt
20 ## │           ├── 2
21 ## │           │   └── 2.txt
22 ## │           ├── 3
23 ## │           │   └── 3.txt
24 ## │           ├── 4
25 ## │           └── 5
26 ## │               └── 5.txt
27 ##
28 ## Target directory structure:
29 ##
30 ## ├── x
31 ## │   └── y
32 ##
33 ## Expected Result:
34 ##
35 ## ├── x
36 ## │   └── y
37 ## |       ├── 1
38 ## │       ├── 2
39 ## │       ├── 3
40 ## │       ├── 4
41 ## │       └── 5
42 #
43 ############################################################
44 ##
45 ## discussion
46 ##
47 ############################################################
48 #
49 # This basically has to duplicate a directory tree, but without
50 # any files - which I would interpret as "not even special files
51 # like named pipes, device files, symlinks etc" (the whole code
52 # would be much more complicated to handle those, albeit not
53 # impossible to do)
54 # While the example above uses absolute source and target directories,
55 # there is no reason why this couldn't also work with relative
56 # source and target as well.
57 # We can either do this whole thing manually or use File::Find.
58 # Since the latter is much more convenient, we try it here ;-)
59 
60 use strict;
61 use warnings;
62 use File::Find;
63 
64 my ($source, $target) = @ARGV;
65 die "Usage: $0 <source> <target>" unless $source and $target;
66 
67 find( { "wanted" => \&wanted, "no_chdir" => 1 } , $source);
68 
69 sub wanted {
70    my $new = $File::Find::name;
71    if(-d $new) {
72       $new =~ s/^\Q$source\E/$target/;
73       ensure_dir($new);
74    }
75 }
76 
77 # create a directory and all its parents if missing
78 sub ensure_dir {
79    my $dir = shift;
80    $dir =~ s/\/*$//; # remove trailing "/"
81    return if -d $dir;
82    if($dir =~ m/\//) {
83       # we seem to have multiple parts in this path
84       my $prefix = $dir;
85       $prefix =~ s#/[^/]*$##;
86       ensure_dir($prefix); # make sure all parents exist
87    }
88    mkdir $dir or die "Can't mkdir $dir: $!";
89 }