Tolgar
asked on
How to do a smart copy between directories using Perl?
Hi,
I have a code that copies files between directories. However, the requirements slightly changed and now this code does not satisfy them.
The new requirements are like this:
1- This script should copy files from bin and lib directories of a product into bin and lib directories under version/$timeStamp/ directory.
The $timeStamp (preferably in this format. YearMonthDay e.g. 20140122) directory and the bin and lib directories in it are going to be created while running the script.
And if there is a previous $timeStamp directory (let's say it was created before by running this script) in the version directory, the bin and lib directories in this last $timeStamp directory should be copied to the new $timeStamp directory first. And then the copy process should start. So that, the files that were copied from other products into this old $timeStamp directory will be guaranteed that they will be in the last $timeStamp directory after the copy process which copied files and directories from the requested source directory (product).
By doing that we will keep all previous versions in the version directory and other product files will not be impacted.
2- The next part is to create symbolic link to the last $timeStamp directory. In order to do that, the script should first ask this to the user and if the user says yes, then it should change the symbolic link to the latest $timeStamp directory in the version folder. Otherwise, it should not change it. The symbolic link should be between the prod and the last $timeStamp directory. The prod directory will be in the same level as the products. (please see the example in the attachment.)
I attached an example directory structure in the zip file.
The version directory in the attached zip file has two directories in it just for representation in this example. In the actual scenario, version directory should not exist at all. And then it should be created in the first run after making sure it does not exist. And then, in time version directory will accumulate $timeStamp directories. If at some point somebody deletes it by mistake, the code should recognize that it does not exist and it should create it again. The better way is to check if version directory does exist, if not then the script should create it otherwise, it can use the existing one.
Since $timeStamp consists of year, month and day, it would cause a problem if you need to run the script twice in one day. Therefore, the code should check if the same name directory exists in the version directory, then it should add a number to the end of the timeStamp name. (e.g. 20140122-2. Because 20140122 already exists)
NOTE: Any directory other then bin and lib in the product directories should be ignored in the copy process. For example, in the attachment I posted, StoreS/11 has somedir7 directory. It should NOT be copied at all.
3- The other new requirement is the information that is printed on the screen when there is a conflict. It would be better if the owner of the conflicting file and the file size is also printed along with the file name.
4- Would it be possible not to need to need to type "." after the command to mention the current location.
The preferred way of running this script is the name of the script and the product name.
I attached visual designs as well to make it more clear.
Thanks,
TEST.zip
IMG-20140122-205437.jpg
IMG-20140122-205449.jpg
IMG-20140122-205458.jpg
I have a code that copies files between directories. However, the requirements slightly changed and now this code does not satisfy them.
The new requirements are like this:
1- This script should copy files from bin and lib directories of a product into bin and lib directories under version/$timeStamp/ directory.
The $timeStamp (preferably in this format. YearMonthDay e.g. 20140122) directory and the bin and lib directories in it are going to be created while running the script.
And if there is a previous $timeStamp directory (let's say it was created before by running this script) in the version directory, the bin and lib directories in this last $timeStamp directory should be copied to the new $timeStamp directory first. And then the copy process should start. So that, the files that were copied from other products into this old $timeStamp directory will be guaranteed that they will be in the last $timeStamp directory after the copy process which copied files and directories from the requested source directory (product).
By doing that we will keep all previous versions in the version directory and other product files will not be impacted.
2- The next part is to create symbolic link to the last $timeStamp directory. In order to do that, the script should first ask this to the user and if the user says yes, then it should change the symbolic link to the latest $timeStamp directory in the version folder. Otherwise, it should not change it. The symbolic link should be between the prod and the last $timeStamp directory. The prod directory will be in the same level as the products. (please see the example in the attachment.)
I attached an example directory structure in the zip file.
The version directory in the attached zip file has two directories in it just for representation in this example. In the actual scenario, version directory should not exist at all. And then it should be created in the first run after making sure it does not exist. And then, in time version directory will accumulate $timeStamp directories. If at some point somebody deletes it by mistake, the code should recognize that it does not exist and it should create it again. The better way is to check if version directory does exist, if not then the script should create it otherwise, it can use the existing one.
Since $timeStamp consists of year, month and day, it would cause a problem if you need to run the script twice in one day. Therefore, the code should check if the same name directory exists in the version directory, then it should add a number to the end of the timeStamp name. (e.g. 20140122-2. Because 20140122 already exists)
NOTE: Any directory other then bin and lib in the product directories should be ignored in the copy process. For example, in the attachment I posted, StoreS/11 has somedir7 directory. It should NOT be copied at all.
3- The other new requirement is the information that is printed on the screen when there is a conflict. It would be better if the owner of the conflicting file and the file size is also printed along with the file name.
4- Would it be possible not to need to need to type "." after the command to mention the current location.
The preferred way of running this script is the name of the script and the product name.
e.g. releaseScript.pl CodeS/12I attached visual designs as well to make it more clear.
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;
}Thanks,
TEST.zip
IMG-20140122-205437.jpg
IMG-20140122-205449.jpg
IMG-20140122-205458.jpg
ASKER
@wilcoxon: you are right. The archive dir is not needed.
Thanks a lot.
Thanks a lot.
ASKER
@wilcoxon: I tried to run the script on the test file I sent you and I got this error:
% perl release2Production.pl CodingS/12/
Usage: release2Production.pl prod_dirs
e.g release2Production.pl . rel1.3ASKER
@wilcoxon: I would appreciate if you could let me know tonight so that I can test it before tomorrow.
Thanks,
Thanks,
ASKER
@wilcoxon: any idea?
ASKER
@wilcoxon: I think, for the error I sent you, the solution would be to trim the last directory from the path while doing grep on allDirs. Because having a directory in the product such as rel1.2 is guaranteed
I hope this would help to solve the issue.
Thanks,
I hope this would help to solve the issue.
Thanks,
ASKER
@wilcoxon: any news?
ASKER
@wilcoxon: The deleted files cannot be detected correctly in the new code. I assume the new directory layer such as rel1.2 made it not working.
In this case, the comparison should be done by checking the content of the newest directory in the product folder. Because there is no general rule/convention for this directory name. But the newest one is the most up to date one.
And I changed the as below to fix the previous problem:
I am waiting for your reply.
Thanks,
In this case, the comparison should be done by checking the content of the newest directory in the product folder. Because there is no general rule/convention for this directory name. But the newest one is the most up to date one.
And I changed the as below to fix the previous problem:
use strict;
use warnings;
use File::Copy qw(cp);
use File::Find;
use File::Path qw(mkpath rmtree);
my @tmp = (localtime)[5,4,3];
$tmp[0] += 1900;
$tmp[1]++;
my $ts = join '', @tmp;
@tmp = ();
## 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 = '.';
#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{^(?:version|prod|\.+)$}o } readdir DIR;
#my @dirs = grep { exists $chk{$_} } @alldirs;
push(my @dirs, $ARGV[0]);
closedir DIR;
die "Usage: $0 prod_dirs\n e.g release2Production.pl Coding-Standards/rel1.3/\n" unless @dirs;
print "base dir $dir\n";
print "checking @dirs...\n";
my ($base, %files, %multi, %dest);
# check for ts dir existence
if (-d 'version' and -d "version/$ts") {
my $num = 2;
$num++ while (-d "version/$ts-$num");
$ts = "$ts-$num";
}
# copy from most recent timestamp dir and catalog dest files
if (opendir DIR, 'version') {
my @dirs = sort { $b <=> $a } grep { -d "version/$_" } readdir DIR;
closedir DIR;
my $rec = $dirs[0];
$base = "version/$rec";
File::Find::find({wanted => \&base}, "version/$rec") if (-d "version/$rec");
foreach my $fil (keys %dest) {
my $dir = $fil;
$dir =~ s{/[^/]+$}{};
mkpath("version/$ts/$dir") unless (-d "version/$ts/$dir");
cp "version/$rec/$fil", "version/$ts/$fil"
or die "could not copy version/$rec/$fil to $ts: $!";
}
}
my $var = substr($dirs[0],length($dirs[0])-1);
if ($var eq "/"){
chop($dirs[0]);
}
# 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 "Found conflict for $file after resolutions\n"
unless (@{$files{$file}} == 1);
# print "cp $files{$file}[0]/$file\n";
my $dir = $file;
$dir =~ s{/[^/]+$}{};
mkpath("version/$ts/$dir") unless (-d "version/$ts/$dir");
cp "$files{$file}[0]/$file", "version/$ts/$file"
or die "could not copy $files{$file}[0]/$file to $ts: $!";
}
# 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: $!";
}
}
if (-d "version/$ts") {
my $val = prompt('m', { prompt => "do you want link prod to $ts?",
title => 'symlink', items => ['quit', 'yes'],
cols => 1, display_base => 0 }, '', undef);
if ($val) {
unlink 'prod';
symlink("version/$ts", 'prod');
}
}
## subroutines
# File::Find wanted routines
sub base {
return unless -f $_;
my $name = $File::Find::name;
$name =~ s{^$base/}{};
return unless ($name =~ m{^(?:bin|lib)/});
$dest{$name}++;
}
sub search {
return unless -f $_;
my $name = $File::Find::name;
$name =~ s{^$base/}{};
return unless ($name =~ m{^(?:bin|lib)/});
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/}{};
return unless ($name =~ m{^(?:bin|lib)/});
$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;
}I am waiting for your reply.
Thanks,
ASKER
@wilcoxon: I made slight changes to the code and it works as expected except detecting the deleted files.
How can I do it by looking at the last created directory in the products (such as CodeS) directory?
Please see the last version on the script below:
How can I do it by looking at the last created directory in the products (such as CodeS) directory?
Please see the last version on the script below:
use strict;
use warnings;
use File::Copy qw(cp);
use File::Find;
use File::Path qw(mkpath rmtree);
my @tmp = (localtime)[5,4,3];
$tmp[0] += 1900;
$tmp[1]++;
my $ts = join '', @tmp;
@tmp = ();
## 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 = '.';
#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{^(?:version|prod|\.+)$}o } readdir DIR;
#my @dirs = grep { exists $chk{$_} } @alldirs;
push(my @dirs, $ARGV[0]);
closedir DIR;
die "Usage: $0 prod_dirs\n e.g release2Production.pl Coding-Standards/rel1.3/\n" unless @dirs;
print "base dir $dir\n";
print "checking @dirs...\n";
my ($base, %files, %multi, %dest);
# check for ts dir existence
if (-d 'version' and -d "version/$ts") {
my $num = 2;
$num++ while (-d "version/$ts-$num");
$ts = "$ts-$num";
}
# copy from most recent timestamp dir and catalog dest files
if (opendir DIR, 'version') {
my @dirs = sort { $b <=> $a } grep { -d "version/$_" } readdir DIR;
closedir DIR;
my $rec = $dirs[0];
$base = "version/$rec";
File::Find::find({wanted => \&base}, "version/$rec") if (-d "version/$rec");
foreach my $fil (keys %dest) {
my $dir = $fil;
$dir =~ s{/[^/]+$}{};
mkpath("version/$ts/$dir") unless (-d "version/$ts/$dir");
cp "version/$rec/$fil", "version/$ts/$fil"
or die "could not copy version/$rec/$fil to $ts: $!";
}
}
my $var = substr($dirs[0],length($dirs[0])-1);
if ($var eq "/"){
chop($dirs[0]);
}
# 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);
if (!$val){
system("rm -rf version/$ts/");
exit;
}
} else {
my $val = prompt('m', { prompt => 'what to do?', title => 'no conflicts',
items => ['quit', 'no conflicts - continue'], cols => 1,
display_base => 0 }, '', undef);
if (!$val){
system("rm -rf version/$ts/");
exit;
}
}
## 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 "Found conflict for $file after resolutions\n"
unless (@{$files{$file}} == 1);
# print "cp $files{$file}[0]/$file\n";
my $dir = $file;
$dir =~ s{/[^/]+$}{};
mkpath("version/$ts/$dir") unless (-d "version/$ts/$dir");
cp "$files{$file}[0]/$file", "version/$ts/$file"
or die "could not copy $files{$file}[0]/$file to $ts: $!";
}
# 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 => ['do not delete', 'delete - continue'], cols => 1,
display_base => 0 }, '', undef);
if ($val){
foreach my $fil (@del) {
unlink $fil or die "could not delete $fil: $!";
}
}
}
if (-d "version/$ts") {
my $val = prompt('m', { prompt => "do you want link prod to $ts?",
title => 'symlink', items => ['quit', 'yes'],
cols => 1, display_base => 0 }, '', undef);
if ($val) {
unlink 'prod';
symlink("version/$ts", 'prod');
}
}
## subroutines
# File::Find wanted routines
sub base {
return unless -f $_;
my $name = $File::Find::name;
$name =~ s{^$base/}{};
return unless ($name =~ m{^(?:bin|lib)/});
$dest{$name}++;
}
sub search {
return unless -f $_;
my $name = $File::Find::name;
$name =~ s{^$base/}{};
return unless ($name =~ m{^(?:bin|lib)/});
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/}{};
return unless ($name =~ m{^(?:bin|lib)/});
$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;
}ASKER
@wilcoxon: I finally solved the issues I mentioned earlier.
This is the code I ended up with:
Thanks,
This is the code I ended up with:
use strict;
use warnings;
use File::Copy qw(cp);
use File::Find;
use File::Path qw(mkpath rmtree);
my @tmp = (localtime)[5,4,3];
$tmp[0] += 1900;
$tmp[1]++;
my $ts = join '', @tmp;
@tmp = ();
## 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 = '.';
#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{^(?:version|prod|\.+)$}o } readdir DIR;
#my @dirs = grep { exists $chk{$_} } @alldirs;
push(my @dirs, $ARGV[0]);
closedir DIR;
die "Usage: $0 prod_dirs\n e.g release2Production.pl Coding-Standards/rel1.3/\n" unless @dirs;
print "base dir $dir\n";
print "checking @dirs...\n";
my ($base, %files, %multi, %dest);
# check for ts dir existence
if (-d 'version' and -d "version/$ts") {
my $num = 2;
$num++ while (-d "version/$ts$num");
$ts = $ts.$num;
}
# copy from most recent timestamp dir and catalog dest files
if (opendir DIR, 'version') {
#my @dirs = sort { $a <=> $b } grep { -d "version/$_" } readdir DIR;
#ignore anything that is not a number
my @dirs = sort {
(my $x = $a) =~ s/\D//g;
(my $y = $b) =~ s/\D//g;
($x?$x:0) <=> ($y?$y:0)
} readdir DIR;
closedir DIR;
my $rec = $dirs[-1];
$base = "version/$rec";
File::Find::find({wanted => \&base}, "version/$rec") if (-d "version/$rec");
foreach my $fil (keys %dest) {
my $dir = $fil;
$dir =~ s{/[^/]+$}{};
mkpath("version/$ts/$dir") unless (-d "version/$ts/$dir");
cp "version/$rec/$fil", "version/$ts/$fil"
or die "could not copy version/$rec/$fil to $ts: $!";
}
}
#remove "/" from the command if it ends with "/"
my $var = substr($dirs[0],length($dirs[0])-1);
if ($var eq "/"){
chop($dirs[0]);
}
# 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);
if (!$val){
system("rm -rf version/$ts/");
exit;
}
} else {
my $val = prompt('m', { prompt => 'what to do?', title => 'no conflicts',
items => ['quit', 'no conflicts - continue'], cols => 1,
display_base => 0 }, '', undef);
if (!$val){
system("rm -rf version/$ts/");
exit;
}
}
## 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 "Found conflict for $file after resolutions\n"
unless (@{$files{$file}} == 1);
# print "cp $files{$file}[0]/$file\n";
my $dir = $file;
$dir =~ s{/[^/]+$}{};
mkpath("version/$ts/$dir") unless (-d "version/$ts/$dir");
cp "$files{$file}[0]/$file", "version/$ts/$file"
or die "could not copy $files{$file}[0]/$file to $ts: $!";
}
# check for files to delete
my (%all_files, @del);
foreach my $dir (@alldirs) {
#find the newest created directory in the product folder ($dir)
opendir( DATA_DIR, $dir) || die "Cannot open $dir\n";
#my @versions = sort { $a <=> $b } grep { -d "$dir/$_"} readdir(DATA_DIR);
#ignore anything that is not a number
my @versions = sort {
(my $x = $a) =~ s/\D//g;
(my $y = $b) =~ s/\D//g;
($x?$x:0) <=> ($y?$y:0)
} readdir DATA_DIR;
closedir DATA_DIR;
my $latest_dir = $versions[-1];
$dir = "$dir/$latest_dir";
$base = $dir;
File::Find::find({wanted => \&full_list}, $dir);
}
foreach my $fil (sort keys %dest) {
push @del, "version/$ts/$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 => ['do not delete', 'delete - continue'], cols => 1,
display_base => 0 }, '', undef);
if ($val){
foreach my $fil (@del) {
unlink $fil or die "could not delete $fil: $! \n";
print "Deleted $fil \n";
}
} else{
print "The files were not deleted. \n";
}
}
if (-d "version/$ts") {
my $val = prompt('m', { prompt => "do you want link prod to $ts?",
title => 'symlink', items => ['quit', 'yes'],
cols => 1, display_base => 0 }, '', undef);
if ($val) {
unlink 'prod';
symlink("version/$ts", 'prod');
} else{
exit;
}
}
## subroutines
# File::Find wanted routines
sub base {
return unless -f $_;
my $name = $File::Find::name;
$name =~ s{^$base/}{};
return unless ($name =~ m{^(?:bin|lib)/});
$dest{$name}++;
}
sub search {
return unless -f $_;
my $name = $File::Find::name;
$name =~ s{^$base/}{};
return unless ($name =~ m{^(?:bin|lib)/});
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/}{};
return unless ($name =~ m{^(?:bin|lib)/});
$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;
}Thanks,
ASKER
@wilcoxon: This is the final code that I have and it works as expected.
But, I am having hard time to read some part of it.
Can you please put some more comments especially for the "base", "search" and "full_list" subroutines? (and this type of line: my $name = $File::Find::name;)
I would appreciate if you could add more comment in general.
Thanks,
But, I am having hard time to read some part of it.
Can you please put some more comments especially for the "base", "search" and "full_list" subroutines? (and this type of line: my $name = $File::Find::name;)
I would appreciate if you could add more comment in general.
Thanks,
#!/usr/local/apps/bat/latest/bin/perl
use strict;
use warnings;
use File::Find;
use File::Path qw(mkpath rmtree);
my @tmp = (localtime)[5,4,3];
$tmp[0] += 1900;
$tmp[1]++;
my $ts = join '', @tmp;
@tmp = ();
## 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 = '.';
opendir DIR, '.' or die "could not open $dir: $!";
my @alldirs = grep { -d $_ and $_ !~ m{^(?:version|prod|\.+)$}o } readdir DIR;
push(my @dirs, $ARGV[0]);
closedir DIR;
die "Usage: $0 prod_dirs\n e.g release2Production.pl Coding-Standards/1.3/\n" unless @dirs;
print "base dir $dir\n";
print "checking @dirs...\n";
my ($base, %files, %multi, %dest);
# check for ts dir existence
if (-d 'version' and -d "version/$ts") {
my $num = 2;
$num++ while (-d "version/$ts$num");
$ts = $ts.$num;
}
# copy from most recent timestamp dir and catalog dest files
if (opendir DIR, 'version') {
#ignore anything that is not a number while sorting
my @dirs = sort {
(my $x = $a) =~ s/\D//g;
(my $y = $b) =~ s/\D//g;
($x?$x:0) <=> ($y?$y:0)
} readdir DIR;
closedir DIR;
my $rec = $dirs[-1];
$base = "version/$rec";
File::Find::find({wanted => \&base}, "version/$rec") if (-d "version/$rec");
foreach my $fil (keys %dest) {
my $dir = $fil;
$dir =~ s{/[^/]+$}{};
mkpath("version/$ts/$dir") unless (-d "version/$ts/$dir");
`cp -r "version/$rec/$fil" "version/$ts/$fil"`
}
}
#remove "/" from the command if it ends with "/"
my $var = substr($dirs[0],length($dirs[0])-1);
if ($var eq "/"){
chop($dirs[0]);
}
# 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);
if (!$val){
system("rm -rf version/$ts/");
exit;
}
} else {
my $val = prompt('m', { prompt => 'what to do?', title => 'no conflicts',
items => ['quit', 'no conflicts - continue'], cols => 1,
display_base => 0 }, '', undef);
if (!$val){
system("rm -rf version/$ts/");
exit;
}
}
# copy files
foreach my $file (keys %files) {
die "Found conflict for $file after resolutions\n"
unless (@{$files{$file}} == 1);
# print "cp $files{$file}[0]/$file\n";
my $dir = $file;
$dir =~ s{/[^/]+$}{};
mkpath("version/$ts/$dir") unless (-d "version/$ts/$dir");
`cp "$files{$file}[0]/$file" "version/$ts/$file"`
}
# check for files to delete
my (%all_files, @del);
foreach my $dir (@alldirs) {
#find the newest created directory in the product folder ($dir)
opendir( DATA_DIR, $dir) || die "Cannot open $dir\n";
#ignore anything that is not a number while sorting
my @versions = sort {
(my $x = $a) =~ s/\D//g;
(my $y = $b) =~ s/\D//g;
($x?$x:0) <=> ($y?$y:0)
} readdir DATA_DIR;
closedir DATA_DIR;
my $latest_dir = $versions[-1];
$dir = "$dir/$latest_dir";
$base = $dir;
File::Find::find({wanted => \&full_list}, $dir);
}
foreach my $fil (sort keys %dest) {
push @del, "version/$ts/$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 => ['do not delete', 'delete - continue'], cols => 1,
display_base => 0 }, '', undef);
if ($val){
foreach my $fil (@del) {
unlink $fil or die "could not delete $fil: $! \n";
print "Deleted $fil \n";
}
} else{
print "The files were not deleted. \n";
}
}
if (-d "version/$ts") {
my $val = prompt('m', { prompt => "do you want link prod to $ts?",
title => 'symlink', items => ['quit', 'yes'],
cols => 1, display_base => 0 }, '', undef);
if ($val) {
unlink 'prod';
symlink("version/$ts", 'prod');
} else{
exit;
}
}
## subroutines
# File::Find wanted routines
sub base {
return unless -f $_;
my $name = $File::Find::name;
$name =~ s{^$base/}{};
return unless ($name =~ m{^(?:bin|lib)/});
$dest{$name}++;
}
sub search {
return unless -f $_;
my $name = $File::Find::name;
$name =~ s{^$base/}{};
return unless ($name =~ m{^(?:bin|lib)/});
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/}{};
return unless ($name =~ m{^(?:bin|lib)/});
$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;
}
Sorry. Things have continued to be really busy.
Glad you were able to figure it out. Deleted files are now working as well?
Sure - I'll add some more comments when I have some time.
For the specifics you were asking about (&base, &search, &full_list, and $name=$File::Find::name), they are all related to File::Find. The perldoc for that module should explain them.
Glad you were able to figure it out. Deleted files are now working as well?
Sure - I'll add some more comments when I have some time.
For the specifics you were asking about (&base, &search, &full_list, and $name=$File::Find::name), they are all related to File::Find. The perldoc for that module should explain them.
ASKER
@wilcoxon: The delete functionality also works. I really appreciate your help.
Can you please put some more comments to the code tonight, if possible?
Thanks,
Can you please put some more comments to the code tonight, if possible?
Thanks,
ASKER
Hi Wilcoxon,
Thank you for all your replies to this question.
I will closing this question but I have another follow-up question. Can you please look at it?
You know the history of this question, so it may be better if you help me.
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,
Thank you for all your replies to this question.
I will closing this question but I have another follow-up question. Can you please look at it?
You know the history of this question, so it may be better if you help me.
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,
ASKER
Hi Wilcoxon,
Can you please let me know if you could help me with my new questions before Wednesday?
Thanks,
Can you please let me know if you could help me with my new questions before Wednesday?
Thanks,
Sure. I'll add comments to the code for this question on Saturday and then take a look at the new question. I'm not sure if I'll have time to do the code changes for the new question on Saturday or not.
ASKER
Thanks. I appreciate your help.
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
ASKER
Hi Wilcoxon,
Will you be able to look at my other question? The code is a little bit different than this one. So, it would be great if you could make changes on top of my version in my last post?
Thanks,
Will you be able to look at my other question? The code is a little bit different than this one. So, it would be great if you could make changes on top of my version in my last post?
Thanks,
I'll try. I ran out of time yesterday and am not sure how busy this week will be overall.
ASKER
ok. Thanks. I will wait for your reply.
ASKER
@wilcoxon: any news about my last post?
ASKER
@wilcoxon: Do you think you can take a look at my other open question on Friday or Saturday?
Thanks,
Thanks,
ASKER
@wilcoxon: any news?
ASKER
@wilcoxon: do you think you can take a look at my last post this weekend?
Thanks,
Thanks,
ASKER
@wilcoxon: I marked my last post as "need attention" but no one has commented on it yet. Do you think you will be able to take a look at it?
ASKER
@wilcoxon: I think my last question was sent to the experts but I haven't heard from them yet. Since they are not familiar with the code, the question might have looked scary.
Can you please let me know if you will be able to take look at it?
Thanks,
Can you please let me know if you will be able to take look at it?
Thanks,
ASKER
Hi Wilcoxon,
I wonder if you are around?
Thanks,
I wonder if you are around?
Thanks,
ASKER
@wilcoxon: I feel like you are not going to respond to my last post. Am I right? If this is the case, I will look for other options to resolve the issue. Please let me know.
Thanks,
Thanks,
Sorry. I honestly intend to look at it. However, things have continued being really busy. I may have time to look at it this Saturday (but I can't guarantee it). I'm surprised nobody else has taken a stab at it (beyond suggesting rsync).
ASKER
Thanks wilcoxon.
I solved the symlink change.
But the other one is still unresolved. I would appreciate if you could take a look at it.
Thanks,
I solved the symlink change.
But the other one is still unresolved. I would appreciate if you could take a look at it.
Thanks,
ASKER
Hi Wilcoxon,
Do you think you will be able to take a look at my question? An admin sent me a comment that I need to close my question and re-open another one due to no response.
If you won't be able to take a look at it, I will do it but I prefer you take this question.
Thanks,
Do you think you will be able to take a look at my question? An admin sent me a comment that I need to close my question and re-open another one due to no response.
If you won't be able to take a look at it, I will do it but I prefer you take this question.
Thanks,
Sorry I never got a chance to look at your new question - it's been a really busy few months for me. I see you have now deleted the question. I hope you were able to figure out the remaining issue on your own.
ASKER
Thanks Wilcoxon. I figured it out. I also appreciate your help.
Open in new window