Want to protect your cyber security and still get fast solutions? Ask a secure question today.Go Premium

x
  • Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 234
  • Last Modified:

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

0
Tolgar
Asked:
Tolgar
  • 9
  • 2
1 Solution
 
TolgarAuthor Commented:
Any idea?
0
 
ozoCommented:
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?
0
 
TolgarAuthor Commented:
@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:

http://www.experts-exchange.com/Programming/Languages/Scripting/Perl/Q_28319462.html

http://www.experts-exchange.com/Programming/Languages/Scripting/Perl/Q_28329207.html

http://www.experts-exchange.com/Programming/Languages/Scripting/Perl/Q_28337275.html


Please help!

Thanks,
0
Concerto Cloud for Software Providers & ISVs

Can Concerto Cloud Services help you focus on evolving your application offerings, while delivering the best cloud experience to your customers? From DevOps to revenue models and customer support, the answer is yes!

Learn how Concerto can help you.

 
ozoCommented:
I don't at see anything in the code that would make it work differently under someproduct1/ compared to how it would work under someproduct1/relx.y/ so if it works under one directory but not the other, my guess would be that there is probably something different about the directories that it works for compared to the directories that it does not work for, and we would have to figure out what that difference is before we can know what modifications may be necessary

It also looks like it is already ignoring directories that are not listed after the base_dir as one of the prod_dirs or is one of of bin|lib|archive|prod or consist of all .'s
so I'm wondering what prod_dirs you are specfying when it is not ignoring something that it should.
0
 
TolgarAuthor Commented:
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
0
 
TolgarAuthor Commented:
@ozo: Were you able to reproduce it?
0
 
TolgarAuthor Commented:
@ozo: Will you be able to take a look at it soon?

Thanks,
0
 
TolgarAuthor Commented:
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
0
 
TolgarAuthor Commented:
@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,
0
 
TolgarAuthor Commented:
@ozo: I created this new question with the new requirements.

http://www.experts-exchange.com/Programming/Languages/Scripting/Perl/Q_28345551.html

Thanks,
0
 
TolgarAuthor Commented:
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:

http://www.experts-exchange.com/Programming/Languages/Scripting/Perl/Q_28352953.html


Thanks,
0

Featured Post

Technology Partners: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

  • 9
  • 2
Tackle projects and never again get stuck behind a technical roadblock.
Join Now