home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Simtel MSDOS - Coast to Coast
/
simteldosarchivecoasttocoast2.iso
/
perl
/
dosmap.prl
< prev
next >
Wrap
Text File
|
1994-03-07
|
7KB
|
274 lines
#!/usr/local/bin/perl
#
# dosmap a unix directory hierarchy
#
# (C) Afzal Ballim, 1993
# Please send any bug reports, etc., to:
# Afzal Ballim, <afzal@divsun.unige.ch>
# ISSCO, University of Geneva, Switzerland
#
# two arguments: 1) what to dosmap
# 2) where to put it
#
# one optional argument: -i interactive name change
#
# Stages:
# 1: Identify filenames to change
# 2: Copy original to new with new names
# 3: Change references in new files to reflect
# the name changes
#
# A filename can stay as it is if
# a) it only uses lowercase letters
# and b) it has a form ?[8].?[3] (i.e., 8 characters max,
# followed by 3 characters max separated by a point)
# or b1) max 8 characters, no ``.''
#
# otherwise it must be changed
# Note that directories must also have their names checked
# simplify process name
$0 =~ s@^.*/@@;
if (@ARGV != 2 && @ARGV != 3) {
print "Usage: $0 [-i] <hierarchy to $0> <where to place result>\n";
print "If the optional argument -i is given, then you will be prompted for\n";
print "replacement names (with a suggested name, selectable by <CR>).\n";
exit(1);
}
if (@ARGV == 3) {
if ($ARGV[0] eq "-i") {
shift(@ARGV);
$Interactive = 1;
print STDERR "You will be prompted for replacement names\n";
}
else {die "$0: unknown argument $ARGV[0]\n";}
}
$Start=shift(@ARGV);
$Destn=shift(@ARGV);
$xcounter=0;
print "Dosmap-ing $Start and putting result in $Destn\n";
print "===========","=" x length($Start);
print "=======================","=" x length($Destn), "\n";
print "\nChecking names...\n";
if (! -e $Start) {
die "$0: $Start does not exist!\n";
}
# find non-conforming files
open(FIND,"find $Start -print |") || die "$0: find - not available\n";
# 1 - read file/directory names, note bad ones
while ($file=<FIND>) {
chop $file;
@bd = split(m@/@,$file); # split into components
if (! &good_dos($bd[$#bd])) {
push(@BNames,$bd[$#bd]);
};
push(@hierarch,$file);
}
close(FIND);
# 2 - sort bad names, eliminate duplicates, generate replacements
@to_replace = &uniq(sort @BNames);
foreach $badname (@to_replace) {
push(@replacements,($badname,&make_repl($badname)));
print "$badname will be replaced by $replacements[$#replacements]\n";
}
# 2a - make up a "program" of replacements
while (@replacements) {
$pat = &protectspec(shift(@replacements));
$rpc = shift(@replacements);
# need two patterns, one for start of line, other for
# non-start of line, can't use \b because of patterns
# starting with .
push(@rep,join('/',
("s", '([^A-Za-z0-9_-])' . $pat . '\b',
'${1}' . $rpc,"og")));
push(@rep,join('/',
("s", '^' . $pat . '\b',
$rpc,"og")));
}
$rep_prog = join(";\n",@rep) . ";\n";
# 2b - make replacements in hierarchy names
print "Generating new hierarchy, wait...\n";
foreach $s (@hierarch) {
$_ = $s;
eval $rep_prog;
local ($d) = $Destn . "/" . $_;
if (-l $s) { #symbolic link
print "Ignoring symbolic link $s\n";
}
elsif (-d $s) {
print "Making directory ",$d," for ",$s,"\n";
if (-e $d) {
die "$0: $d already exists! Probable filename change error\n";
}
mkdir($d,0xFFF) || die "$0: Couldn't make $d\n";
}
else { # file, perform changes
print "copying ",$s," to ",$d," with changes\n";
if (-e $d) {
die "$0: $d already exists! Probable filename change error\n";
}
open(FIN,$s)|| die "$0: couldn't open $s\n";
open(FOUT,"> $d")||die "$0: couldn't open $d\n";
# am I recompiling the program for each line of each file?
while (<FIN>) {
eval $rep_prog;
print FOUT;
}
close(FIN);
close(FOUT);
}
}
print "done\n";
############################################################
#
# Subroutines
#
############################################################
# is it a good dos name?
sub good_dos {
$_=@_[0];
/^[^A-Z]*$/o && /^[^.]{1,8}$|^[^.]{1,8}\.[^.]{1,3}$/o;
}
# remove duplicates from a sorted list
sub uniq {
local (@duplic) = @_;
local ($this);
local (@res);
while (@duplic) {
$this=shift(@duplic);
while (@duplic && $this eq $duplic[0]) {shift(@duplic);}
push(@res,$this);
}
return @res;
}
# protect special characters
sub protectspec {
local ($pat) = @_;
local (@p) = split('',$pat);
local (@p2);
foreach $c (@p) {
if ($c =~ /(\.\-\_)/) {
$c = $1;
}
push(@p2,$c);
}
join('',@p2);
}
# make a replacement name for a bad one
sub make_repl {
local ($badname) = @_;
local ($sug) = &gena_repl($badname);
if ($Interactive) {
local ($grp) = 0;
while (!$grp) {
print STDERR "Replacement for ",$badname,"[$sug]:";
chop($_ = <STDIN>);
if ($_ ne "") {$sug = $_}
if (! &good_dos($sug)) {
print "$sug is not a valid dos name\n";
} else {
$grp=1;
}
}
}
return $sug;
}
# generate a replacement name automagically
sub gena_repl {
local ($thename) = @_;
local (@field1,@field2);
# how can we generate a name?
# 1: convert to lowercase, delete all but 1 "."
$thename=~ tr/A-Z/a-z/;
local (@tmp) = reverse split('',$thename);
while (@tmp && $tmp[0] ne ".") {
unshift(@field2,shift(@tmp));
}
if (@tmp) { shift(@tmp) }
while (@tmp) {
if ($tmp[0] eq ".") {
shift(@tmp);
}
else {
unshift(@field1,shift(@tmp));
}
}
# if there is no field1, make field2 field1
if (!@field1) {
@field1 = @field2;
@field2 = ();
}
# 2: reduce fields that are too big
@field1 = &reducefield(8,@field1);
@field2 = &reducefield(3,@field2);
# 3: increase first field if zero sized
@field1 = &nonzerofield(@field1);
if (@field2) {
return join('.',join('',@field1),join('',@field2));
}
else {
return join('',@field1);
}
}
# reducefield
sub reducefield {
local ($lim,@f) = @_;
local ($to_del) = $#f-$lim+1;
if ($#f < $lim) {
return @f;
}
# 2a: get rid of all vowels,-,_, except 1st letter vowel
# 2b: if still too long, cut from middle (hoping start and end
# are more important).
local (@res) = shift(@f);
while (@f) {
if ($f[0] =~ /[aeiou_-]/o && $to_del) {
$to_del--;
shift(@f);
}
else {
push(@res,shift(@f));
}
}
if ($#res < $lim) {
return @res;
}
else {
return (@res[0 .. int($lim/2)+$lim%2-1],
@res[$#res+1-int($lim/2) .. $#res])
}
}
# nonzerofield, if field has zero size, return a number
sub nonzerofield {
local (@field) = @_;
if ($#field) {
return @field
} else
{ return split('',sprintf("%08.d",$xcounter++));}
}