Solved

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

Posted on 2014-01-20
11
208 Views
Last Modified: 2014-01-30
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
Comment
Question by:Tolgar
  • 9
  • 2
11 Comments
 

Author Comment

by:Tolgar
ID: 39795975
Any idea?
0
 
LVL 84

Expert Comment

by:ozo
ID: 39796105
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
 

Author Comment

by:Tolgar
ID: 39796724
@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
 
LVL 84

Accepted Solution

by:
ozo earned 500 total points
ID: 39796780
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
 

Author Comment

by:Tolgar
ID: 39797101
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
IT, Stop Being Called Into Every Meeting

Highfive is so simple that setting up every meeting room takes just minutes and every employee will be able to start or join a call from any room with ease. Never be called into a meeting just to get it started again. This is how video conferencing should work!

 

Author Comment

by:Tolgar
ID: 39797729
@ozo: Were you able to reproduce it?
0
 

Author Comment

by:Tolgar
ID: 39799019
@ozo: Will you be able to take a look at it soon?

Thanks,
0
 

Author Comment

by:Tolgar
ID: 39800175
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
 

Author Comment

by:Tolgar
ID: 39800666
@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
 

Author Comment

by:Tolgar
ID: 39801015
@ozo: I created this new question with the new requirements.

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

Thanks,
0
 

Author Comment

by:Tolgar
ID: 39823071
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

IT, Stop Being Called Into Every Meeting

Highfive is so simple that setting up every meeting room takes just minutes and every employee will be able to start or join a call from any room with ease. Never be called into a meeting just to get it started again. This is how video conferencing should work!

Join & Write a Comment

I've just discovered very important differences between Windows an Unix formats in Perl,at least 5.xx.. MOST IMPORTANT: Use Unix file format while saving Your script. otherwise it will have ^M s or smth likely weird in the EOL, Then DO NOT use m…
On Microsoft Windows, if  when you click or type the name of a .pl file, you get an error "is not recognized as an internal or external command, operable program or batch file", then this means you do not have the .pl file extension associated with …
Explain concepts important to validation of email addresses with regular expressions. Applies to most languages/tools that uses regular expressions. Consider email address RFCs: Look at HTML5 form input element (with type=email) regex pattern: T…
It is a freely distributed piece of software for such tasks as photo retouching, image composition and image authoring. It works on many operating systems, in many languages.

707 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

15 Experts available now in Live!

Get 1:1 Help Now