Learning Perl Challenge: Remove intermediate directories

I often run into situations where I have directories that contain only one file, a subdirectory, with contain only one file, a subdirectory, and so on for a long chain, until I get to the interesting files. These situations come up when I have only part of a data set so the files that would be in other directories aren’t there, and I find it annoying to deal with these long directory specifications. So, this challenge is to fix that by collapsing those one-entry directories into a single one.

For example, you should take this structure, where you have A/B/C/D/E in a direct line with no other branches:

and turn it into this one, with a single directory with the files that were at the end:

However, you should only moves files up if the directory above it has only one entry (which must be a subdirectory!). In this example, A/B/C has two subdirectories in it:

so the the files in E should only move up into D. Otherwise, the files from the two branches in C would get mixed up with each other.

5 thoughts on “Learning Perl Challenge: Remove intermediate directories”

  1. In the second example, shouldn’t D and F end up in A, since B contains *only* C?

  2. #!/usr/bin/perl
    use strict;
    use warnings;
    use File::Path qw(remove_tree);
    use File::Copy qw(move);
    my ($dir) = @ARGV;
    short_dir($dir) ;
    sub short_dir {
    	my ($start, $now) = @_;
    	return unless(-d $start);
    	$now ||= $start;
    	my @subnodes = glob("$now/*");
    	my @subdirs = grep { -d $_ } @subnodes;
    		short_dir($_) for @subdirs;
    		short_dir($start, $subdirs[0]);
    		return if($start eq $now);
    		move($_, "$start/") for @subnodes;	
    		my @dirs = grep { -d $_ } glob("$start/*");
  3. Not as easy as it seems. My solution works as Szymon proposed. Some details would still need discussion with the client, though 🙂 For example, each empty directory without siblings disappears. The script probably does not work correctly for /, but I did not have enough courage to test it. Also, I might have used a bit more than Learning Perl teaches – I have read more books.

    use warnings;
    use strict;
    use Cwd 'abs_path';
    use constant SELF_OR_PARENT => qr/^\.\.?$/;
    sub collapse {
        my $dir = shift;
        opendir my($DH), $dir;
        my $count = 0;
        my $previous;
        while (my $file = readdir $DH) {
            next DIR if $file =~ SELF_OR_PARENT;
            last DIR if ++$count > 1;
            $previous = $file;
        if ($count == 1
                and defined $previous
                and -d (my $fullpath = "$dir/$previous")
           ) {
            my ($path, $dirname) = $dir =~ m=(.*)/(.*)=;
            rename $fullpath, "$dir/../_$dirname" or die $!;
            rmdir $dir or die $!;
            rename "$path/_$dirname", $dir or die $!;
        } else {
            opendir my ($DH), $dir;
            while (my $subdir = readdir $DH) {
                collapse("$dir/$subdir") if -d "$dir/$subdir"
                                         and $subdir !~ SELF_OR_PARENT;
    my $top = shift;
    die "$top is not a dir" unless -d $top;
    $top = abs_path($top);
  4. I’m mainly a C++ programmer, but I tried my hand at perl this time. I used a recursive function and shell commands.

    sub checkAndDelete{
    	if(!(-d $_[0])){
    	my $command="ls ".$_[0];
    	$scc=~s/ /\n/;
    	my @files=split("\n",$scc);
    	my $size=@files;
    	my $fprefix=$_[0];
    	my $lastc=substr($fprefix,-1);
    	if(!($lastc eq "/")){
    	if($size==1 and -d(($fprefix.$files[0]))){
    		my $cpcom="cp -a ".$fprefix.$files[0]."/. ".$fprefix;
    		system("rm -r ".$fprefix.$files[0]);
    	for(my $i=0;$i<$size;$i++){
    @ARGV>0 or die 'Insufficient arguments';
    -d $ARGV[0] or die 'Incorrect path';

Comments are closed.