added c: option for jdk
[feisty_meow.git] / scripts / files / filename_helper.pl
1 #!/usr/bin/perl
2
3 ###############################################################################
4 #                                                                             #
5 #  Name   : filename_helper                                                   #
6 #  Author : Chris Koeritz                                                     #
7 #  Rights : Copyright (C) 1996-$now by Author                                 #
8 #                                                                             #
9 #  Purpose:                                                                   #
10 #                                                                             #
11 #    Support for manipulating filenames.                                      #
12 #                                                                             #
13 ###############################################################################
14 #  This program is free software; you can redistribute it and/or modify it    #
15 #  under the terms of the GNU General Public License as published by the Free #
16 #  Software Foundation; either version 2 of the License or (at your option)   #
17 #  any later version.  See: "http://www.gruntose.com/Info/GNU/GPL.html" for a #
18 #  version of the License.  Please send any updates to "fred@gruntose.com".   #
19 ###############################################################################
20
21 require "importenv.pl";
22
23 ############################################################################
24
25 #hmmm: make this lower-level, a script that is inherited by all perl scripts.
26
27 sub yeti_interrupt_handler {
28   die "caught an interrupt; exiting.\n";
29 }
30
31 # hook in a ctrl-c catcher, since that seems to be universally needed.
32 sub install_interrupt_catcher {
33   $SIG{INT} = 'yeti_interrupt_handler';
34   $SIG{QUIT} = 'yeti_interrupt_handler';
35 #print "mapped int and quit signals\n";
36   return 0
37 }
38
39 ############################################################################
40
41 # takes an array of filenames (each possibly containing spaces and/or
42 # wildcards) and resolves it to a useful list of actual files.
43
44 sub glob_list {
45   local(@temp_list) = @_;  # the names we're given.
46   local(@to_return) = ();  # the final form of the name list.
47 #print "temp list is @temp_list\n";
48
49   # scan through the list we're given.
50   foreach $entry (@temp_list) {
51 #print "entry is $entry\n";
52     local(@chopped_filename) = &split_filename($entry);
53 #print "chopped 0=$chopped_filename[0]\n";
54 #print "chopped 1=$chopped_filename[1]\n";
55     if ( (@chopped_filename[0] eq ".") || (@chopped_filename[0] eq "..") ) {
56       # add the simple directory name into the list.
57       push @to_return, $chopped_filename[0];
58       next;
59     }
60     if (@chopped_filename[1] eq ".") {
61       # add a directory that didn't have more pattern attached.
62       push @to_return, $chopped_filename[0];
63       next;
64     }
65     opendir WHERE, $chopped_filename[0];  # open the directory up.
66     local(@files_found) = readdir(WHERE);
67     closedir WHERE;
68     foreach $possible_name (@files_found) {
69       # zoom through the list and see if we need to add it to the ones
70       # matching the passed in patterns.
71 #      if ( ($possible_name eq ".") || ($possible_name eq "..") ) { 
72 #        # skip the directory entries.
73 #        print "skipping dir entries\n";
74 #        next;
75 #      }
76       # we need to process this a bit; directory patterns are different.
77       local($match) = $chopped_filename[1];
78       $match =~ s/\./\\./g;  # replace periods with escaped ones.
79       $match =~ s/\*/.*/g;  # replace asterisks with dot star.
80       $match =~ s/\+/\\+/g;  # escape plusses.
81       $match = "^" . $match . "\$";  # make sure the whole thing matches.
82 #print "possibname is $possible_name\n";
83       if ($possible_name =~ /$match/) {
84         # this one matches so add it.
85         push @to_return, $chopped_filename[0] . $possible_name;
86       }
87     }
88   }
89   return @to_return;
90 }
91
92 ############################################################################
93
94 # reports if two file names are the same file.
95
96 sub same_file {
97   local($file1, $file2) = @_;
98  
99   ($dev1, $ino1, $junk1) = stat $file1;
100   ($dev2, $ino2, $junk2) = stat $file2;
101
102   return ($dev1 == $dev2) && ($ino1 == $ino2);
103 }
104
105 ############################################################################
106
107 # splits a filename into a directory and file specification.
108
109 sub split_filename {
110   local($chewed_name) = &remove_trailing_slashes(@_);
111   $chewed_name = &canonicalize($chewed_name);
112   $chewed_name = &patch_name_for_pc($chewed_name);
113   if ($chewed_name =~ /\//) {
114     # there's a slash in there.
115     local($directory_part) = $chewed_name;
116     $directory_part =~ s/^(.*\/)[^\/]*$/\1/;
117     local($file_part) = $chewed_name;
118     $file_part =~ s/^.*\/([^\/]*)$/\1/;
119     if ($file_part eq "") {
120       # if there was no file specification, just add a non-matching spec.
121       $file_part = ".";
122     }
123     return ($directory_part, $file_part);
124   } elsif ($chewed_name eq ".") {
125     return (".", "");
126   } elsif ($chewed_name eq "..") {
127     return ("..", "");
128   } else {
129     # no slash in this name, so we fix that and also make sure we match
130     # the whole name.
131     return ("./", $chewed_name);
132   }
133 }
134
135 ############################################################################
136
137 # returns the base part of the filename; this omits any directories.
138
139 sub basename {
140   local(@parts) = &split_filename(@_);
141   return $parts[1];
142 }
143
144 # returns the directory part of the filename.
145
146 sub dirname {
147   local(@parts) = &split_filename(@_);
148   return $parts[0];
149 }
150
151 # returns the extension found on the filename, if any.
152 sub extension {
153   local($base) = &basename(@_);
154 #printf "base is $base\n";
155   local($found) = -1;
156   for (local($i) = length($base) - 1; $i >= 0; $i--) {
157 #printf "char is " . substr($base, $i, 1) . "\n";
158     if (substr($base, $i, 1) eq '.') {
159       $found = $i;
160 #printf "got period found is $found\n";
161       last;
162     }
163   }
164   if ($found >=0) {
165     return substr($base, $found, length($base) - $found);
166   }
167   return "";  # no extension seen.
168 }
169
170 # returns the portion of the filename without the extension.
171 sub non_extension {
172   local($full) = &remove_trailing_slashes(@_);
173   $full = &canonicalize($full);
174   $full = &patch_name_for_pc($full);
175   local($ext) = &extension($full);
176   local($to_remove) = length($ext);
177   return substr($full, 0, length($full) - $to_remove);
178 }
179
180 ############################################################################
181
182 # removes all directory slashes (either '/' or '\') from the end of a string.
183
184 sub remove_trailing_slashes {
185   local($directory_name) = @_;
186   # start looking at the end of the string.
187   local($inspection_point) = length($directory_name) - 1;
188   while ($inspection_point > 0) {
189     # examine the last character in the string to see if it's a slash.
190     local($final_char) = substr($directory_name, $inspection_point, 1);
191     # leave the loop if it's not a slash.
192     if ( ($final_char ne "/") && ($final_char ne "\\") ) { last; }
193     chop($directory_name);  # remove the slash.
194     $inspection_point--;  # check the new last character.
195   }
196
197   return $directory_name;
198 }
199
200 ############################################################################
201
202 # returns the proper directory separator for this platform.  this requires
203 # an environment variable called "OS" for non-Unix operating systems.  the
204 # valid values for that are shown below.
205
206 sub directory_separator {
207   if ( ($OS eq "Windows_NT") || ($OS eq "Windows_95") 
208       || ($OS eq "DOS") || ($OS eq "OS2") ) { return "\\"; }
209   else { return "/"; }
210 }
211
212 ############################################################################
213
214 # these mutate the directory slashes in a directory name.
215
216 # the one we use most frequently; it uses the unix slash.
217 sub canonicalize {
218   return &canonicalizer(@_, "/");
219 }
220
221 # one that turns names into the style native on the current platform.
222 sub native_canonicalize {
223   return &canonicalizer(@_, &directory_separator());
224 }
225
226 # one that explicitly uses pc style back-slashes.
227 sub pc_canonicalize {
228   return &canonicalizer(@_, "\\");
229 }
230
231 # one that explicitly does unix style forward slashes.
232 sub unix_canonicalize {
233   return &canonicalizer(@_, "/");
234 }
235
236 # similar to the normal unix version, but supports msys's weird paths.
237 sub msys_canonicalize {
238   return &canonicalizer(@_, "/", 1);
239 }
240
241 # similar to the msys version, but services cygwin.
242 sub cygwin_canonicalize {
243   return &canonicalizer(@_, "/", 2);
244 }
245
246
247 # this more general routine gets a directory separator passed in.  it then
248 # replaces all the separators with that one.
249
250 sub canonicalizer {
251   local($directory_name) = $_[0];
252   local($dirsep) = $_[1];
253   local($do_funky) = $_[2];
254 #print "do funky is set to \"$do_funky\"\n";
255
256 #print "old dir name is \"$directory_name\"\n";
257   
258   if ($OS =~ /win/i) {
259 #somewhat abbreviated check; only catches windoze systems, not dos or os2.
260     if ($do_funky eq "1") {
261       # msys utilities version (http://www.mingw.org)
262       $directory_name =~ s/^(.):[\\\/](.*)$/\/\1\/\2/;
263     } elsif ($do_funky eq "2") {
264       # cygwin utilities version (http://www.cygwin.com)
265       $directory_name =~ s/^(.):[\\\/](.*)$/\/cygdrive\/\1\/\2/;
266     }
267 #print "new dir name is \"$directory_name\"\n";
268   }
269
270   # turn all the non-default separators into the default.
271   for (local($j) = 0; $j < length($directory_name); $j++) {
272     if ( (substr($directory_name, $j, 1) eq "\\") 
273         || (substr($directory_name, $j, 1) eq "/") ) {
274       substr($directory_name, $j, 1) = $dirsep;
275     }
276   }
277   # remove all occurrences of double separators except for the first
278   # double set, which could be a UNC filename.
279   local($saw_sep) = 0;
280   for (local($i) = 1; $i < length($directory_name); $i++) {
281     # iterate through the string looking for redundant separators.
282     if (substr($directory_name, $i, 1) eq $dirsep) {
283       # we found a separator character.
284       if ($saw_sep) {
285         # we had just seen a separator, so this is two in a row.
286         local($head, $tail) = (substr($directory_name, 0, $i - 1),
287             substr($directory_name, $i, length($directory_name) - 1));
288         $directory_name = $head . $tail;
289           # put the name back together without this redundant character.
290         $i--;  # skip back one and try again.
291       } else {
292         # we have now seen a separator.
293         $saw_sep = 1;
294       }
295     } else {
296       # this character was not a separator.
297       $saw_sep = 0;
298     }
299   }
300   if ($directory_name =~ /^.:$/) {
301     # fix a dos style directory that's just X:, since we don't want the
302     # current directory to be used on that device.  that's too random.
303     # instead, we assume they meant the root of the drive.
304     $directory_name = $directory_name . "/";
305   }
306   return $directory_name;
307 }
308
309 ############################################################################
310
311 # fixes a PC directory name if it is only a drive letter plus colon.
312
313 sub patch_name_for_pc {
314   local($name) = @_;
315 #print "name=$name\n";
316   if (length($name) != 2) { return $name; }
317   local($colon) = substr($name, 1, 1);
318 #print "colon=$colon\n";
319   # check whether the string needs patching.
320   if ($colon eq ":") {
321     # name is currently in feeble form of "X:"; fix it.
322     $name = $name . '/';
323   }
324 #print "returning=$name\n";
325   return $name;
326 }
327
328 ############################################################################
329
330 # tells whether a filename is important or not.  the unimportant category
331 # can usually be safely ignored or deleted.
332
333 sub important_filename {
334   local($name) = &basename($_[0]);
335   
336   # these are endings that we consider unimportant.  where a caret is used
337   # at the front, we will match only the whole string.  double slashes are
338   # used before periods to ensure we match a real period character.
339
340 #      "AssemblyInfo.c.*",
341 #need to regenerate these automatically.
342
343   local(@junk_files) = ("~", "^\\.#.*", "^\\._.*", "\\.aps", "\\.bak",
344       "^binaries", 
345       "\\.clw", "^cpdiff_tmp\\.txt", "^\\.ds_store", "^diffs\\.txt",
346       "^diff_tmp\\.txt", "\\.dsp", "\\.dsw", "\\.gid", "gmon\\.out", "\\.isr",
347       "^isconfig\\.ini", "\\.log", "^manifest.txt", "^obj",
348       "\\.obj", "\\.output", "\\.plg", "^RCa.*", "^Release", "\\.res",
349       "\\.sbr", ".*scc", "^Setup\\.dbg", "^Setup\\.inx",
350       "^Setup\\.map", "^Setup\\.obs", "^Selenium_.*Login.html",
351       "\\.stackdump", "^string1033\\.txt", "\\.suo", "\\.swp",
352       "^thumbs.db", "\\.tmp", "^trans\\.tbl", "\\.user", "_version\\.h",
353       "_version\\.rc", "^waste", "\\.ws4", "\\.wsm");
354 #this whacks too much.  what was it for?
355 #"^generated_.*", 
356
357   foreach $temp (@junk_files) {
358     $temp = $temp . '$';
359     if ($name =~ /${temp}/i) { return 0; }
360       # we hit a match on it being unimportant.
361   }
362
363   return 1;  # anything else is considered important.
364 }
365
366 ############################################################################
367
368 sub sanitize_name {
369   return &patch_name_for_pc
370       (&remove_trailing_slashes
371           (&canonicalize(@_)));
372 }
373
374 ############################################################################
375
376 sub get_drive_letter {
377   local($path) = @_;
378   if (substr($path, 0, 1) =~ /[a-zA-Z]/) {
379     if (substr($path, 1, 1) eq ":") { return substr($path, 0, 1); }
380   }
381   return "";
382 }
383
384 ############################################################################
385
386 sub remove_drive_letter {
387   local($path) = @_;
388   if (substr($path, 0, 1) =~ /[a-zA-Z]/) {
389     if (substr($path, 1, 1) eq ":") { return substr($path, 2); }
390   }
391   return $path;
392 }
393
394 ############################################################################
395
396 # these return their argument with the case flipped to lower or upper case.
397
398 sub lower {
399   local($name) = @_;
400   $name =~ tr/A-Z/a-z/;
401   return $name;
402 }
403
404 sub upper {
405   local($name) = @_;
406   $name =~ tr/a-z/A-Z/;
407   return $name;
408 }
409
410 ############################################################################
411
412 # recursively deletes a directory that is passed as the single parameter.
413 # from http://developer.novell.com/wiki/index.php/Recursive_Directory_Remove
414 sub recursive_delete {
415   my $dir = shift;
416   local *DIR;
417
418   opendir DIR, $dir or die "opendir $dir: $!";
419   my $found = 0;
420   while ($_ = readdir DIR) {
421     next if /^\.{1,2}$/;
422     my $path = "$dir/$_";
423     unlink $path if -f $path;
424     recursive_delete($path) if -d $path;
425   }
426   closedir DIR;
427   rmdir $dir or print "error - $!";
428 }
429
430 ############################################################################
431
432 1;
433