Link to home
Start Free TrialLog in
Avatar of Tolgar
Tolgar

asked on

How to change my existing Perl code to satisfy the two requirements during copying files

Hi,
The following code can copy files from one directory to another. It can also detect the conflicts and previously deleted files during the copy process and prompts to the user.

However, there are two things that needs to be changed in this code and I need your help about it.

1- The copy process in this code can be done for the following directory structure:

someproduct1/bin/ 
someproduct1/lib/

Open in new window



However, the actual directory structure is like this (these one more level between the product and the bin and lib directories):

someproduct1/relx.y/bin/ 
someproduct1/relx.y/lib/

Open in new window


and this code does not work for this directory structure.

Note: relx.y is just a dummy name for a directory. It can be anything

2- There can be other directories in the product/relx.y/ directory other than bin and lib. And these directories should be ignored in this copy process. In this code they are not ignored.


Can you please help me to make these two changes in the following code?

use strict;
use warnings;
use File::Copy qw(cp);
use File::Find;
use File::Path qw(mkpath rmtree);

## taken from Term::Prompt
use Carp;
use Text::Wrap;
use Term::ReadKey qw (GetTerminalSize ReadMode);

our $DEBUG = 0;
our $MULTILINE_INDENT = "\t";

my %menu = (
            order => 'down',
            return_base => 0,
            display_base => 1,
            accept_multiple_selections => 0,
            accept_empty_selection => 0,
            title => '',
            prompt => '>',
            separator => '[^0-9]+',
            ignore_whitespace => 0,
            ignore_empties => 0
           );

sub prompt ($$$$;@);
# End Term::Prompt

my $dir = shift or die "Usage: $0 base_dir prod_dirs\n";
my %chk = map { $_ => 1 } @ARGV;
chdir $dir or die "could not cd to $dir: $!";
opendir DIR, '.' or die "could not open $dir: $!";
my @alldirs = grep { -d $_ and $_ !~ m{^(?:bin|lib|archive|prod|\.+)$}o } readdir DIR;
my @dirs = grep { exists $chk{$_} } @alldirs;
closedir DIR;
die "Usage: $0 base_dir prod_dirs\n e.g release2Production.pl . rel1.3\n" unless @dirs;
print "base dir $dir\n";
print "checking @dirs...\n";

my ($base, %files, %multi, %dest);

# catalog dest files
foreach my $dir (qw(bin lib)) {
    File::Find::find({wanted => \&base}, $dir) if (-d $dir);
}

# catalog product files
foreach my $dir (sort @dirs) {
    $base = $dir;
    File::Find::find({wanted => \&search}, $base);
}

if (%multi) {
    foreach my $file (sort keys %multi) {
        if (@{$files{$file}} > 2 or $files{$file}[0] ne '.') {
            warn "unresolvable conflicts found between products for $file:\n"
                . join ("\n", @{$files{$file}}) . "\n";
        }
        print "$file:\t", join("\t", @{$files{$file}}), "\n";
        $files{$file} = [$files{$file}[($files{$file}[0] eq '.') ? 1 : 0]];
    }
    my $val = prompt('m', { prompt => 'what to do?', title => 'conflicts',
                items => ['quit', 'conflicts - continue'], cols => 1,
                display_base => 0 }, '', undef);
    exit unless $val;
} else {
    my $val = prompt('m', { prompt => 'what to do?', title => 'no conflicts',
                items => ['quit', 'no conflicts - continue'], cols => 1,
                display_base => 0 }, '', undef);
    exit unless $val;
}

# create archive
rmtree('archive');
foreach my $fil (keys %dest) {
    my $dir = "archive/$fil";
    $dir =~ s{/[^/]+$}{};
    mkpath($dir) unless (-d $dir);
    cp $fil, "archive/$fil" or die "could not archive $fil: $!";
}

# copy files
foreach my $file (keys %files) {
    die "woa!! found conflict for $file after resolutions\n"
        unless (@{$files{$file}} == 1);
#    print "cp $files{$file}[0]/$file\n";
    my $dir = $file;
    $dir =~ s{/[^/]+$}{};
    mkpath($dir) unless (-d $dir);
    cp "$files{$file}[0]/$file", $file
            or die "could not copy $files{$file}[0]/$file: $!";
}

# check for files to delete
my (%all_files, @del);
foreach my $dir (@alldirs) {
    $base = $dir;
    File::Find::find({wanted => \&full_list}, $dir);
}
foreach my $fil (sort keys %dest) {
    push @del, $fil unless exists($all_files{$fil});
}
if (@del) {
    print "files to delete:\n\t", join("\n\t", @del), "\n";
    my $val = prompt('m', { prompt => 'what to do?', title => 'delete files',
                items => ['quit', 'delete - continue'], cols => 1,
                display_base => 0 }, '', undef);
    exit unless $val;
    foreach my $fil (@del) {
        unlink $fil or die "could not delete $fil: $!";
    }
}

## subroutines

sub base {
    return unless -f $_;
    my $name = $File::Find::name;
    $dest{$name}++;
}

sub search {
    return unless -f $_;
    my $name = $File::Find::name;
    $name =~ s{^$base/}{};
    if (exists $files{$name}) {
        $multi{$name}++;
        push @{$files{$name}}, $base;
    } elsif (exists $dest{$name}) {
        $multi{$name}++;
        push @{$files{$name}}, '.', $base;
    } else {
        push @{$files{$name}}, $base;
    }
}

sub full_list {
    return unless -f $_;
    my $name = $File::Find::name;
    $name =~ s{^$base/}{};
    $all_files{$name}++;
}

# BEGIN main part of Term::Prompt
# Preloaded methods go here.

sub prompt ($$$$;@) {

    my($mopt, $prompt, $prompt_options, $default, @things) =
      ('','','',undef,());
    my($repl, $match_options, $case, $low, $high, $before, $regexp, $coderef) =
      ('','','','','','','','');
    my $prompt_full = '';

    # Figure out just what we are doing here
    $mopt = $_[0];
    print "mopt is: $mopt\n" if $DEBUG;

    # check the size of the match option, it should just have one char.
    if (length($mopt) == 1 or $mopt =~ /\-n/i or $mopt =~ /\+-n/i) {
        my $dummy = 'mopt is ok';
    } else {
        croak "Illegal call of prompt; $mopt is more than one character; stopped";
    }

    my $type = 0;
    my $menu = 0;
    my $legal = 0;
    my $range = 0;
    my $expr = 0;
    my $code = 0;
    my $yn = 0;
    my $uc = 0;
    my $passwd = 0;

    if ($mopt ne lc($mopt)) {
        $uc = 1;
        $mopt = lc($mopt);
    }

    if ($mopt eq 'm') {
        ($mopt, $prompt, $prompt_options, $default) = @_;
        $menu = 1;
    } else {
        croak "prompt type $mopt not recognized";
    }

    my $ok = 0;

    $mopt = lc($mopt);

    while (1) {

        if ($menu) {

            ## We're working on a menu
            @menu{sort keys %{$prompt}} = @{$prompt}{sort keys %{$prompt}};

            $prompt_full = "$menu{'prompt'} ";

            my @menu_items = @{$menu{'items'}};
            my $number_menu_items = scalar(@menu_items);

            $menu{'low'} = $menu{'display_base'};
            $menu{'high'} = $number_menu_items+$menu{'display_base'}-1;

            my $digits_in_menu_item = (int(log($menu{'high'})/log(10)) + 1);

            my $entry_length = 0;
            my $item_length = 0;
            for (@menu_items) {
                $entry_length = length($_)
                if length($_) > $entry_length;
            }
            $item_length = $entry_length;
            $entry_length += ( $digits_in_menu_item ## Max number of digits in a selection
                               +
                               3 ## two for ') ', at least one for a column separator
                             );

            my $gw = get_width();

            my $num_cols = (defined($menu{'cols'})
                            ? $menu{'cols'}
                            : int($gw/$entry_length));
            $num_cols ||= 1; # Could be zero if longest entry in a
            # list is wider than the screen
            my $num_rows = (defined($menu{'rows'})
                            ? $menu{'rows'}
                            : int($number_menu_items/$num_cols)+1) ;

            my $data_fmt = "%${digits_in_menu_item}d) %-${item_length}.${item_length}s";
            my $column_end_fmt = ("%s ");
            my $line_end_fmt   = ("%s\n");
            my @menu_out = ();
            my $row = 0;
            my $col = 0;
            my $idx = 0;

            if ($menu{order} =~ /ACROSS/i) {
              ACROSS_LOOP:
                for ($row = 0; $row < $num_rows; $row++) {
                    for ($col = 0; $col < $num_cols; $col++) {
                        $menu_out[$row][$col] = sprintf($data_fmt,$idx+$menu{'display_base'},$menu_items[$idx++]);
                        last ACROSS_LOOP
                          if $idx eq scalar(@menu_items);
                    }
                }
            } else {
              DOWN_LOOP:
                for ($col = 0; $col < $num_cols; $col++) {
                    for ($row = 0; $row < $num_rows; $row++) {
                        $menu_out[$row][$col] = sprintf($data_fmt,$idx+$menu{'display_base'},$menu_items[$idx++]);
                        last DOWN_LOOP
                          if $idx eq scalar(@menu_items);
                    }
                }
            }

            if (length($menu{'title'})) {
                print $menu{'title'},"\n",'-' x length($menu{'title'}),"\n";
            }

            for ($row = 0;$row < $num_rows;$row++) {
                for ($col = 0;$col < $num_cols-1;$col++) {
                    printf($column_end_fmt,$menu_out[$row][$col])
                      if defined($menu_out[$row][$col]);
                }
                if (defined($menu_out[$row][$num_cols-1])) {
                    printf($line_end_fmt,$menu_out[$row][$num_cols-1])
                } else {
                    print "\n";
                }
            }

            if ($number_menu_items != ($num_rows)*($num_cols)) {
                print "\n";
            }

            unless (defined($prompt_options) && length($prompt_options)) {
                $prompt_options = "$menu{'low'} - $menu{'high'}";
                if ($menu{'accept_multiple_selections'}) {
                    $prompt_options .= ', separate multiple entries with spaces';
                }
            }
        }

        unless ($before || $uc || ($prompt_options eq '')) {
            $prompt_full .= "($prompt_options) ";
        }

        if (defined($default) and $default ne '') {
            $prompt_full .= "[default $default] ";
        }

        print termwrap($prompt_full);
        my $old_divide = undef;

        if (defined($/)) {
            $old_divide = $/;
        }

        $/ = "\n";

        ReadMode('noecho') if($passwd);
        $repl = scalar(readline(*STDIN));
        ReadMode('restore') if($passwd);

        if (defined($old_divide)) {
            $/ = $old_divide;
        } else {
            undef($/);
        }

        chomp($repl);		# nuke the <CR>

        $repl =~ s/^\s*//;	# ignore leading white space
        $repl =~ s/\s*$//;	# ignore trailing white space

        $repl = $default if $repl eq '';

        print termwrap("Reply: '$repl'\n") if $DEBUG;

        # Now here is where things get real interesting
        my @menu_repl = ();
        if ($menu) {
            $ok = menuit(\@menu_repl, $repl, $DEBUG, $uc);
        } else {
            croak "No subroutine known for prompt type $mopt.";
        }

        if ($ok) {
            if ($menu) {
                if ($menu{'accept_multiple_selections'}) {
                    return (wantarray ? @menu_repl : \@menu_repl);
                } else {
                    return $menu_repl[0];
                }
            }
        } elsif (defined($prompt_options) && length($prompt_options)) {
            if ($uc) {
                print termwrap("$prompt_options\n");
            } else {
                if (!$menu) {
                    print termwrap("Options are: $prompt_options\n");
                }
                $before = 1;
            }
        }
    }
}

sub rangeit ($$$$ ) {
    # this routine makes sure that the reply is within a given range

    my($repl, $low, $high, $uc) = @_;

    if ( $low <= $repl && $repl <= $high ) {
        return 1;
    } elsif (!$uc) {
        print 'Invalid range value.  ';
    }
    return 0;
}

sub menuit (\@$$$ ) {
    my ($ra_repl, $repl, $dbg, $uc) = @_;
    print "inside of menuit\n" if $dbg;

    my @msgs = ();

    ## Parse for multiple values. Strip all whitespace if requested or
    ## just strip leading and trailing whitespace to avoid a being
    ## interpreted as separating empty choices.

    if($menu{'ignore_whitespace'}) {
        $repl =~ s/\s+//g;
    } else {
        $repl =~ s/^(?:\s+)//;
        $repl =~ s/(?:\s+)$//;
    }

    my @repls = split(/$menu{'separator'}/,$repl);
    if($menu{ignore_empties}) {
        @repls = grep{length($_)} @repls;
    }

    ## Validations
    if ( scalar(@repls) > 1
         &&
         !$menu{'accept_multiple_selections'} ) {
        push @msgs, 'Multiple choices not allowed.';
    } elsif (!scalar(@repls)
             &&
             !$menu{'accept_empty_selection'}) {
        push @msgs, 'You must make a selection.';
    } else {
        for (@repls) {
            if ( !rangeit($_,$menu{'low'},$menu{'high'},1)) {
                push @msgs, "$_ is an invalid choice.";
            }
        }
    }

    ## Print errors or return values
    if (scalar(@msgs)) {
        print "\n",join("\n",@msgs),"\n\n";
        return 0;
    } else {
        @{$ra_repl} = map {$_ - $menu{'display_base'} + $menu{'return_base'}} @repls;
        return 1;
    }

}

# The termwrap is used to wrap lines to the width of the currently selected filehandle
sub termwrap ($;@) {
    my($message) = '';
    if ($#_ > 0) {
        if (defined($,)) {
            $message = join($,,@_);
        } else {
            $message = join(' ',@_);
        }
    } else {
        $message = $_[0];
    }

    my $width = get_width();

    if (defined($width) && $width) {
        $Text::Wrap::Columns = $width;
        print $Text::Wrap::Columns if 0; # dummy line to get rid of warning
    }

    if ($message =~ m/\n\Z/) {
        $message = wrap('', $MULTILINE_INDENT, $message);
        $message =~ s/\n*\Z/\n/;
        return $message;
    } else {
        $message = wrap('', $MULTILINE_INDENT, $message);
        $message =~ s/\n*\Z//;
        return $message;
    }
}

# The get_width is used internally by it is likewise available for optional export; 
# it defaults to the current value of Text::Wrap::columns if the width cannot be determined.
sub get_width {
    my($width) = eval {
        local($SIG{__DIE__});
        (GetTerminalSize(select))[0];
    } || eval {
        if (-T STDOUT) {
            local($SIG{__DIE__});
            return (GetTerminalSize STDOUT )[0];
        } else {
            return 0;
        }
    } || eval {
        if (-T STDERR) {
            local($SIG{__DIE__});
            return (GetTerminalSize STDERR )[0];
        } else {
            return 0;
        }
    } || eval {
        local($SIG{__DIE__});
        (GetTerminalSize STDOUT )[0];
    } || eval {
        local($SIG{__DIE__});
        (GetTerminalSize STDERR )[0];
    };
    return $width;
}

Open in new window

Avatar of Tolgar
Tolgar

ASKER

Any idea?
Avatar of ozo
In what way does it not work for a directory structure like
someproduct1/relx.y/bin/
someproduct1/relx.y/lib/

What directories are not ignored, and in what way are they not ignored?
Avatar of Tolgar

ASKER

@ozo: Actually, it does NOT work for a directory structure like this:

someproduct1/relx.y/bin/
someproduct1/relx.y/lib/

So, this is the functionality I try to do:

Copy all files from source directories to a target directory.

The source directories look like this:

 someproduct1/relx.y/bin/
someproduct1/relx.y/lib/
someproduct1/relx.y/somedirA/
someproduct1/relx.y/somedirB/

someproduct2/relx.y/bin/
someproduct2/relx.y/lib/
someproduct2/relx.y/somedirK/
someproduct2/relx.y/somedirD/

someproduct3/relx.y/bin/
someproduct3/relx.y/lib/

someproduct4/relx.y/bin/
someproduct4/relx.y/somedirF/
someproduct4/relx.y/somedirY/

And so on... They all have bin directories. Most of them have lib directory as well. And some of them have other directories as well.

The target location is like this at the same level as the the "someproduct" directories.

bin/
lib/

The idea is to copy all files from bin and lib directories to a shared bin and lib directory. In this copy process, there can be conflicting files between someproducts that came from different products in the target location, so the code detects these conflicts and prompts to the user and asks if it is ok to continue and copy over these files. In addition, there can be deleted files and the code can detect if a file in the target bin and lib directories are also in one of the product directories. and if the file can only be found in the target bin and lib dirrectories but not in any other product directory then the code prompts to the user and asks if it is ok to delete them from the target bin or lib as well.

So, the problems in this code are:

1- It works when there is no extra directory level between someproduct and bin and lib directories. But there will always be one directory level between someproductX and bin or lib such as relx.y in the example above.

2- It is very likely that there will be other directories other than bin and lib in the someproduct directories as in the example above. In this case, the code should ignore these directories while copying.

If these two extra requirements can be satisfied, it would work perfectly.

 Please see my related questions in here:

https://www.experts-exchange.com/questions/28319462/How-to-do-a-smart-copy-of-the-files-between-directories-in-Perl.html

https://www.experts-exchange.com/questions/28329207/How-to-smrt-copy-files-between-folder-in-Perl.html

https://www.experts-exchange.com/questions/28337275/How-to-detect-deleted-files-in-a-smart-copy-between-directories-in-Perl.html


Please help!

Thanks,
ASKER CERTIFIED SOLUTION
Avatar of ozo
ozo
Flag of United States of America image

Link to home
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
Start Free Trial
Avatar of Tolgar

ASKER

ok. I created a test directory with some fake files and directories in it.

Please put this file in your machine and run the following command:

perl release2Production.pl . CodingS

Open in new window


It will copy the 1.2 directory to the same level as this script. But instead it should copy the content of bin in the product to the bin at the top level and content of lib to the lib at the to level.

While doing this, it should be able to detect conflicting and deleted files.

Please change the file extension of "release2Production" to pl. I couldn't attach it with pl extension.

Thanks,
TEST.zip
Avatar of Tolgar

ASKER

@ozo: Were you able to reproduce it?
Avatar of Tolgar

ASKER

@ozo: Will you be able to take a look at it soon?

Thanks,
Avatar of Tolgar

ASKER

Hi,
I updated the test file to make it more robust. And the command that needs to be run is:

perl release2Production.pl . CodingS/12

Open in new window


Please see the new test directory structure in the attachment.

NOTE: please change the file extension to .pl for the release2Production script.

Thanks,
TEST.zip
Avatar of Tolgar

ASKER

@ozo: The requirements change slightly and I believe we have almost everything that does the trick in this code. I will create a new question with the new requirements and then I will close this question.

Thanks,
Avatar of Tolgar

ASKER

Thank you for all your replies to this question.

I am closing this question but I have another followup question. Can you please look at it?

Please see my new question below:

https://www.experts-exchange.com/questions/28352953/How-to-do-smart-copy-with-Perl-by-considering-some-requirements.html


Thanks,