home *** CD-ROM | disk | FTP | other *** search
/ Simtel MSDOS 1994 September / Simtel-MSDOS-Sep1994-CD2.iso / disc2 / perl / dosmap.prl < prev    next >
Encoding:
Text File  |  1993-11-02  |  6.2 KB  |  274 lines
  1. #!/usr/local/bin/perl
  2.  
  3. #
  4. # dosmap a unix directory hierarchy
  5. #
  6. # (C) Afzal Ballim, 1993
  7. # Please send any bug reports, etc., to:
  8. # Afzal Ballim, <afzal@divsun.unige.ch>
  9. # ISSCO, University of Geneva, Switzerland
  10. #
  11. # two arguments: 1) what to dosmap
  12. #         2) where to put it
  13. #
  14. # one optional argument: -i interactive name change
  15. #
  16. # Stages:
  17. #    1: Identify filenames to change
  18. #    2: Copy original to new with new names
  19. #    3: Change references in new files to reflect 
  20. #       the name changes
  21. #
  22. # A filename can stay as it is if
  23. #    a) it only uses lowercase letters
  24. # and    b) it has a form ?[8].?[3] (i.e., 8 characters max,
  25. #       followed by 3 characters max separated by a point)
  26. #    or b1) max 8 characters, no ``.''
  27. #
  28. # otherwise it must be changed
  29. # Note that directories must also have their names checked
  30.  
  31. # simplify process name
  32. $0 =~ s@^.*/@@;
  33.  
  34.  
  35. if (@ARGV != 2 && @ARGV != 3) {
  36.  print "Usage: $0 [-i] <hierarchy to $0> <where to place result>\n";
  37.  print "If the optional argument -i is given, then you will be prompted for\n";
  38.  print "replacement names (with a suggested name, selectable by <CR>).\n";
  39.  exit(1);
  40. }
  41.  
  42. if (@ARGV == 3) {
  43.  if ($ARGV[0] eq "-i") {
  44.   shift(@ARGV);
  45.   $Interactive = 1;
  46.   print STDERR "You will be prompted for replacement names\n";
  47.  }
  48.  else {die "$0: unknown argument $ARGV[0]\n";}
  49. }
  50.  
  51. $Start=shift(@ARGV);
  52. $Destn=shift(@ARGV);
  53. $xcounter=0;
  54.  
  55. print "Dosmap-ing $Start and putting result in $Destn\n";
  56. print "===========","=" x length($Start);
  57. print "=======================","=" x length($Destn), "\n";
  58. print "\nChecking names...\n";
  59.  
  60. if (! -e $Start) {
  61.     die "$0: $Start does not exist!\n";
  62. }
  63.  
  64. # find non-conforming files
  65. open(FIND,"find $Start -print |") || die "$0: find - not available\n";
  66.  
  67.  
  68. # 1 - read file/directory names, note bad ones
  69.  
  70. while ($file=<FIND>) {
  71.     chop $file;
  72.     @bd = split(m@/@,$file); # split into components
  73.     if (! &good_dos($bd[$#bd])) {
  74.         push(@BNames,$bd[$#bd]);
  75.     };
  76.     push(@hierarch,$file);
  77. }
  78. close(FIND);
  79.  
  80. # 2 - sort bad names, eliminate duplicates, generate replacements
  81. @to_replace = &uniq(sort @BNames);
  82. foreach $badname (@to_replace) {
  83.  push(@replacements,($badname,&make_repl($badname)));
  84.  print "$badname will be replaced by $replacements[$#replacements]\n";
  85. }
  86.  
  87. # 2a - make up a "program" of replacements
  88. while (@replacements) {
  89.     $pat = &protectspec(shift(@replacements));
  90.     $rpc = shift(@replacements);
  91.     # need two patterns, one for start of line, other for
  92.     # non-start of line, can't use \b because of patterns
  93.     # starting with .
  94.     push(@rep,join('/',
  95.             ("s", '([^A-Za-z0-9_-])' . $pat . '\b',
  96.              '${1}' . $rpc,"og")));
  97.     push(@rep,join('/',
  98.             ("s", '^' . $pat . '\b',
  99.              $rpc,"og")));
  100. }
  101. $rep_prog = join(";\n",@rep) . ";\n";
  102.  
  103. # 2b - make replacements in hierarchy names
  104. print "Generating new hierarchy, wait...\n";
  105.  
  106. foreach $s (@hierarch) {
  107.     $_ = $s;
  108.     eval $rep_prog;
  109.     local ($d) = $Destn . "/" . $_;
  110.     if (-l $s) { #symbolic link
  111.      print "Ignoring symbolic link $s\n";
  112.         }
  113.     elsif (-d $s) {
  114.      print "Making directory ",$d," for ",$s,"\n";
  115.      if (-e $d) {
  116.       die "$0: $d already exists! Probable filename change error\n";
  117.      }
  118.      mkdir($d,0xFFF) || die "$0: Couldn't make $d\n";
  119.     }
  120.     else { # file, perform changes
  121.      print "copying ",$s," to ",$d," with changes\n";
  122.      if (-e $d) {
  123.       die "$0: $d already exists! Probable filename change error\n";
  124.      }
  125.      open(FIN,$s)|| die "$0: couldn't open $s\n";
  126.      open(FOUT,"> $d")||die "$0: couldn't open $d\n";
  127.     # am I recompiling the program for each line of each file?
  128.      while (<FIN>) {
  129.          eval $rep_prog;
  130.          print FOUT;
  131.      }
  132.      close(FIN);
  133.      close(FOUT);
  134.     }
  135. }
  136. print "done\n";
  137.  
  138. ############################################################
  139. #
  140. # Subroutines
  141. #
  142. ############################################################
  143.  
  144.  
  145. # is it a good dos name?
  146. sub good_dos {
  147.     $_=@_[0];
  148.     /^[^A-Z]*$/o && /^[^.]{1,8}$|^[^.]{1,8}\.[^.]{1,3}$/o;
  149. }
  150.  
  151. # remove duplicates from a sorted list
  152. sub uniq {
  153.     local (@duplic) = @_;
  154.     local ($this);
  155.     local (@res);
  156.  
  157.     while (@duplic) {
  158.         $this=shift(@duplic);
  159.         while (@duplic && $this eq $duplic[0]) {shift(@duplic);}
  160.         push(@res,$this);
  161.     }
  162.     return @res;
  163. }
  164.  
  165. # protect special characters
  166. sub protectspec {
  167.     local ($pat) = @_;
  168.     local (@p) = split('',$pat);
  169.     local (@p2);
  170.     foreach $c (@p) {
  171.         if ($c =~ /(\.\-\_)/) {
  172.             $c = $1;
  173.         }
  174.         push(@p2,$c);
  175.     }
  176.     join('',@p2);
  177. }
  178.  
  179. # make a replacement name for a bad one
  180. sub make_repl {
  181.  local ($badname) = @_;
  182.  local ($sug) = &gena_repl($badname);
  183.  if ($Interactive) {
  184.     local ($grp) = 0;
  185.     while (!$grp) {
  186.      print STDERR "Replacement for  ",$badname,"[$sug]:";
  187.      chop($_ = <STDIN>);
  188.      if ($_ ne "") {$sug = $_}
  189.      if (! &good_dos($sug)) {
  190.          print "$sug is not a valid dos name\n";
  191.      } else {
  192.          $grp=1;
  193.      }
  194.     }
  195.  }
  196.  return $sug;
  197. }
  198.  
  199. # generate a replacement name automagically
  200. sub gena_repl {
  201.  local ($thename) = @_;
  202.  local (@field1,@field2);
  203.   # how can we generate a name?
  204.   # 1: convert to lowercase, delete all but 1 "."
  205.   $thename=~ tr/A-Z/a-z/;
  206.   local (@tmp) = reverse split('',$thename);
  207.   while (@tmp && $tmp[0] ne ".") {
  208.    unshift(@field2,shift(@tmp));
  209.   }
  210.   if (@tmp) { shift(@tmp) }
  211.   while (@tmp) {
  212.    if ($tmp[0] eq ".") {
  213.     shift(@tmp);
  214.    }
  215.    else {
  216.     unshift(@field1,shift(@tmp));
  217.    }
  218.   }
  219.   # if there is no field1, make field2 field1
  220.   if (!@field1) {
  221.       @field1 = @field2;
  222.       @field2 = ();
  223.   }
  224.   # 2: reduce fields that are too big
  225.   @field1 = &reducefield(8,@field1);
  226.   @field2 = &reducefield(3,@field2);
  227.   # 3: increase first field if zero sized
  228.   @field1 = &nonzerofield(@field1);
  229.  if (@field2) { 
  230.   return join('.',join('',@field1),join('',@field2));
  231.  }
  232.  else {
  233.   return join('',@field1);
  234.  }
  235. }
  236.  
  237. # reducefield
  238. sub reducefield {
  239.   local ($lim,@f) = @_;
  240.   local ($to_del) = $#f-$lim+1;
  241.   if ($#f < $lim) {
  242.       return @f;
  243.   }
  244.   # 2a: get rid of all vowels,-,_, except 1st letter vowel
  245.   # 2b: if still too long, cut from middle (hoping start and end
  246.   #     are more important).
  247.   local (@res) = shift(@f);
  248.   while (@f) {
  249.    if ($f[0] =~ /[aeiou_-]/o && $to_del) {
  250.        $to_del--;
  251.        shift(@f);
  252.    }
  253.    else {
  254.        push(@res,shift(@f));
  255.    }
  256.   }
  257.   if ($#res < $lim) {
  258.       return @res;
  259.   } 
  260.   else {
  261.       return (@res[0 .. int($lim/2)+$lim%2-1],
  262.           @res[$#res+1-int($lim/2) .. $#res])
  263.   }
  264. }
  265.  
  266. # nonzerofield, if field has zero size, return a number
  267. sub nonzerofield {
  268.  local (@field) = @_;
  269.  if ($#field) {
  270.     return @field
  271.   } else
  272.   { return split('',sprintf("%08.d",$xcounter++));}
  273. }
  274.