Merge branch 'master' of feistymeow.org:feisty_meow into dev
[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 use Env qw(OS IS_MSYS);
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       # we need to process the pattern a bit; directory patterns are different
70       # from perl regular expression patterns, so we end up massaging any "ls"
71       # wildcards into an equivalent perl-style one below.
72       local($match) = $chopped_filename[1];
73 #hmmm: would be nice to combine the replacements into a long batch instead of separate commands, but i do not seem to know how to do that yet in perl.
74       $match =~ s/\./\\./g;  # replace periods with escaped ones.
75       $match =~ s/\*/.*/g;  # replace asterisks with dot star.
76       $match =~ s/\+/\\+/g;  # escape plusses.
77       $match =~ s/\?/\\?/g;  # escape question marks.
78       $match =~ s/\|/\\?/g;  # escape pipe char.
79       $match =~ s/\$/\\\$/g;  # escape dollar sign.
80       $match =~ s/\[/\\[/g;  # escape open bracket.
81       $match =~ s/\]/\\]/g;  # escape close bracket.
82       $match =~ s/\(/\\(/g;  # escape open quote.
83       $match =~ s/\)/\\)/g;  # escape close quote.
84       $match =~ s/\{/\\{/g;  # escape open curly bracket.
85       $match =~ s/\}/\\}/g;  # escape close curly bracket.
86
87       $match = "^" . $match . "\$";  # make sure the whole thing matches.
88 #print "possibname is '$possible_name':\n";
89       if ($possible_name =~ /$match/) {
90         # this one matches so add it.
91         push @to_return, $chopped_filename[0] . $possible_name;
92       }
93     }
94   }
95   return @to_return;
96 }
97
98 ############################################################################
99
100 # reports if two file names are the same file.
101
102 sub same_file {
103   local($file1, $file2) = @_;
104  
105   ($dev1, $ino1, $junk1) = stat $file1;
106   ($dev2, $ino2, $junk2) = stat $file2;
107
108   return ($dev1 == $dev2) && ($ino1 == $ino2);
109 }
110
111 ############################################################################
112
113 # splits a filename into a directory and file specification.
114
115 sub split_filename {
116   local($chewed_name) = &remove_trailing_slashes(@_);
117   $chewed_name = &canonicalize($chewed_name);
118   $chewed_name = &patch_name_for_pc($chewed_name);
119   if ($chewed_name =~ /\//) {
120     # there's a slash in there.
121     local($directory_part) = $chewed_name;
122     $directory_part =~ s/^(.*\/)[^\/]*$/\1/;
123     local($file_part) = $chewed_name;
124     $file_part =~ s/^.*\/([^\/]*)$/\1/;
125     if ($file_part eq "") {
126       # if there was no file specification, just add a non-matching spec.
127       $file_part = ".";
128     }
129     return ($directory_part, $file_part);
130   } elsif ($chewed_name eq ".") {
131     return (".", "");
132   } elsif ($chewed_name eq "..") {
133     return ("..", "");
134   } else {
135     # no slash in this name, so we fix that and also make sure we match
136     # the whole name.
137     return ("./", $chewed_name);
138   }
139 }
140
141 ############################################################################
142
143 # returns the base part of the filename; this omits any directories.
144
145 sub basename {
146   local(@parts) = &split_filename(@_);
147   return $parts[1];
148 }
149
150 # returns the directory part of the filename.
151
152 sub dirname {
153   local(@parts) = &split_filename(@_);
154   return $parts[0];
155 }
156
157 # returns the extension found on the filename, if any.
158 sub extension {
159   local($base) = &basename(@_);
160 #printf "base is $base\n";
161   local($found) = -1;
162   for (local($i) = length($base) - 1; $i >= 0; $i--) {
163 #printf "char is " . substr($base, $i, 1) . "\n";
164     if (substr($base, $i, 1) eq '.') {
165       $found = $i;
166 #printf "got period found is $found\n";
167       last;
168     }
169   }
170   if ($found >=0) {
171     return substr($base, $found, length($base) - $found);
172   }
173   return "";  # no extension seen.
174 }
175
176 # returns the portion of the filename without the extension.
177 sub non_extension {
178   local($full) = &remove_trailing_slashes(@_);
179   $full = &canonicalize($full);
180   $full = &patch_name_for_pc($full);
181   local($ext) = &extension($full);
182   local($to_remove) = length($ext);
183   return substr($full, 0, length($full) - $to_remove);
184 }
185
186 ############################################################################
187
188 # removes all directory slashes (either '/' or '\') from the end of a string.
189
190 sub remove_trailing_slashes {
191   local($directory_name) = @_;
192   # start looking at the end of the string.
193   local($inspection_point) = length($directory_name) - 1;
194   while ($inspection_point > 0) {
195     # examine the last character in the string to see if it's a slash.
196     local($final_char) = substr($directory_name, $inspection_point, 1);
197     # leave the loop if it's not a slash.
198     if ( ($final_char ne "/") && ($final_char ne "\\") ) { last; }
199     chop($directory_name);  # remove the slash.
200     $inspection_point--;  # check the new last character.
201   }
202
203   return $directory_name;
204 }
205
206 ############################################################################
207
208 # returns the proper directory separator for this platform.  this requires
209 # an environment variable called "OS" for non-Unix operating systems.  the
210 # valid values for that are shown below.
211
212 sub directory_separator {
213   if ( ($OS eq "Windows_NT") || ($OS eq "Windows_95") 
214       || ($OS eq "DOS") || ($OS eq "OS2") ) { return "\\"; }
215   else { return "/"; }
216 }
217
218 ############################################################################
219
220 # these mutate the directory slashes in a directory name.
221
222 # the one we use most frequently; it uses the unix slash.
223 sub canonicalize {
224   return &canonicalizer(@_, "/");
225 }
226
227 # one that turns names into the style native on the current platform.
228 sub native_canonicalize {
229   return &canonicalizer(@_, &directory_separator());
230 }
231
232 # one that explicitly uses pc style back-slashes.
233 sub pc_canonicalize {
234   return &canonicalizer(@_, "\\");
235 }
236
237 # one that explicitly does unix style forward slashes.
238 sub unix_canonicalize {
239   return &canonicalizer(@_, "/");
240 }
241
242 # this more general routine gets a directory separator passed in.  it then
243 # replaces all the separators with that one.
244 sub canonicalizer {
245   local($directory_name) = $_[0];
246   local($dirsep) = $_[1];
247
248 #print "old dir name is \"$directory_name\"\n";
249   
250   if ($OS =~ /win/i) {
251 #somewhat abbreviated check; only catches windoze systems, not dos or os2.
252     # IS_MSYS is calculated by feisty meow scripts startup; it will be
253     # non-empty if this is the msys tool kit.
254     if (length($IS_MSYS) > 0) {
255       # msys utilities version (http://www.mingw.org)
256       $directory_name =~ s/^(.):[\\\/](.*)$/\/\1\/\2/;
257     } else {
258       # cygwin utilities version (http://www.cygwin.com)
259       $directory_name =~ s/^(.):[\\\/](.*)$/\/cygdrive\/\1\/\2/;
260     }
261 #print "new dir name is \"$directory_name\"\n";
262   }
263
264   # turn all the non-default separators into the default.
265   for (local($j) = 0; $j < length($directory_name); $j++) {
266     if ( (substr($directory_name, $j, 1) eq "\\") 
267         || (substr($directory_name, $j, 1) eq "/") ) {
268       substr($directory_name, $j, 1) = $dirsep;
269     }
270   }
271   # remove all occurrences of double separators except for the first
272   # double set, which could be a UNC filename.
273   local($saw_sep) = 0;
274   for (local($i) = 1; $i < length($directory_name); $i++) {
275     # iterate through the string looking for redundant separators.
276     if (substr($directory_name, $i, 1) eq $dirsep) {
277       # we found a separator character.
278       if ($saw_sep) {
279         # we had just seen a separator, so this is two in a row.
280         local($head, $tail) = (substr($directory_name, 0, $i - 1),
281             substr($directory_name, $i, length($directory_name) - 1));
282         $directory_name = $head . $tail;
283           # put the name back together without this redundant character.
284         $i--;  # skip back one and try again.
285       } else {
286         # we have now seen a separator.
287         $saw_sep = 1;
288       }
289     } else {
290       # this character was not a separator.
291       $saw_sep = 0;
292     }
293   }
294   if ($directory_name =~ /^.:$/) {
295     # fix a dos style directory that's just X:, since we don't want the
296     # current directory to be used on that device.  that's too random.
297     # instead, we assume they meant the root of the drive.
298     $directory_name = $directory_name . "/";
299   }
300   return $directory_name;
301 }
302
303 ############################################################################
304
305 # fixes a PC directory name if it is only a drive letter plus colon.
306
307 sub patch_name_for_pc {
308   local($name) = @_;
309 #print "name=$name\n";
310   if (length($name) != 2) { return $name; }
311   local($colon) = substr($name, 1, 1);
312 #print "colon=$colon\n";
313   # check whether the string needs patching.
314   if ($colon eq ":") {
315     # name is currently in feeble form of "X:"; fix it.
316     $name = $name . '/';
317   }
318 #print "returning=$name\n";
319   return $name;
320 }
321
322 ############################################################################
323
324 # tells whether a filename is important or not.  the unimportant category
325 # can usually be safely ignored or deleted.
326
327 sub important_filename {
328   local($name) = &basename($_[0]);
329   
330   # these are endings that we consider unimportant.  where a caret is used
331   # at the front, we will match only the whole string.  double slashes are
332   # used before periods to ensure we match a real period character.
333   local(@junk_files) = ("~", "^\\.#.*", "^\\._.*", "\\.aps", "\\.bak",
334       "^binaries", "^bin.ant", "^bin.eclipse",
335       "\\.clw", "^cpdiff_tmp\\.txt", "^\\.ds_store", "^diffs\\.txt",
336       "^diff_tmp\\.txt", "\\.dsp", "\\.dsw", "\\.gid", "gmon\\.out", "\\.isr",
337       "^isconfig\\.ini", "\\.log", "^manifest.txt", "^obj",
338       "\\.obj", "\\.output", "\\.plg", "^RCa.*", "^Release", "\\.res",
339       "\\.sbr", ".*scc", "^Setup\\.dbg", "^Setup\\.inx",
340       "^Setup\\.map", "^Setup\\.obs", "^Selenium_.*Login.html",
341       "\\.stackdump", "^string1033\\.txt", "\\.suo", "\\.swp",
342       "^thumbs.db", "[a-zA-Z0-9]\\.tmp", "^trans\\.tbl", "\\.user", "_version\\.h",
343       "_version\\.rc", "^waste", "\\.ws4", "\\.wsm");
344
345   foreach $temp (@junk_files) {
346     $temp = $temp . '$';
347     if ($name =~ /${temp}/i) { return 0; }
348       # we hit a match on it being unimportant.
349   }
350
351   return 1;  # anything else is considered important.
352 }
353
354 ############################################################################
355
356 sub sanitize_name {
357   return &patch_name_for_pc
358       (&remove_trailing_slashes
359           (&canonicalize(@_)));
360 }
361
362 ############################################################################
363
364 sub get_drive_letter {
365   local($path) = @_;
366   if (substr($path, 0, 1) =~ /[a-zA-Z]/) {
367     if (substr($path, 1, 1) eq ":") { return substr($path, 0, 1); }
368   }
369   return "";
370 }
371
372 ############################################################################
373
374 sub remove_drive_letter {
375   local($path) = @_;
376   if (substr($path, 0, 1) =~ /[a-zA-Z]/) {
377     if (substr($path, 1, 1) eq ":") { return substr($path, 2); }
378   }
379   return $path;
380 }
381
382 ############################################################################
383
384 # these return their argument with the case flipped to lower or upper case.
385
386 sub lower {
387   local($name) = @_;
388   $name =~ tr/A-Z/a-z/;
389   return $name;
390 }
391
392 sub upper {
393   local($name) = @_;
394   $name =~ tr/a-z/A-Z/;
395   return $name;
396 }
397
398 ############################################################################
399
400 # recursively deletes a directory that is passed as the single parameter.
401 # from http://developer.novell.com/wiki/index.php/Recursive_Directory_Remove
402 sub recursive_delete {
403   my $dir;
404   foreach $dir (@_) {
405     if ( -f "$dir" ) {
406 print "this is not a dir: $dir\nshould whack it here?\n";
407 return;
408     }
409
410     local *DIR;
411     # if we can't open the dir, just skip to the next one.
412     opendir DIR, $dir or next;
413     while ($_ = readdir DIR) {
414       next if /^\.{1,2}$/;
415       my $path = "$dir/$_";
416       unlink $path if -f $path;
417       recursive_delete($path) if -d $path;
418     }
419     closedir DIR;
420     rmdir $dir or print "error - $!";
421   }
422 }
423
424 ############################################################################
425
426 # finds any directories under the arguments, which can be a list of directories.
427 sub find_directories {
428   my @dirs_found = ();
429   my $dir;
430   foreach $dir (@_) {
431     local *DIR;
432     # if we can't open the dir, just skip to the next one.
433     opendir DIR, $dir or next;
434     while ($_ = readdir DIR) {
435       # skip if it's current or parent dir.
436       next if /^\.{1,2}$/;
437       my $path = "$dir/$_";
438       # skip if this entry is not itself a directory.
439       next if ! -d $path;
440       push @dirs_found, $path;
441     }
442     closedir DIR;
443   }
444   return @dirs_found;
445 }
446
447 ############################################################################
448
449 # given a list of paths, this returns an array of all the filenames found therein.
450 sub find_files {
451   my @files_found = ();
452   my $dir;
453   foreach $dir (@_) {
454     if (-f $dir) {
455       # that's actually just a file, so add it.
456       push @files_found, $dir;
457       next;
458     }
459     local *DIR;
460     # if we can't open the dir, just skip to the next one.
461     opendir DIR, $dir or next;
462     while ($_ = readdir DIR) {
463       # skip if it's current or parent dir.
464       next if /^\.{1,2}$/;
465       my $path = "$dir/$_";
466       # skip if this entry is not a file.
467       next if ! -f $path;
468       push @files_found, $path;
469     }
470     closedir DIR;
471   }
472   return @files_found;
473 }
474
475 ############################################################################
476
477 # finds all directories starting at a particular directory and returns them
478 # in an array.  does not include the starting directory.
479 sub recursive_find_directories {
480   # first find all the directories within the parameters.
481   my @toplevel = find_directories(@_);
482
483   my @to_return;
484   push(@to_return, @toplevel);
485
486   # return the composition of the list we found here plus any directories under those.
487   # we only recurse if there's something to chew on in our directory list.
488   # otherwise, we've hit the bottom of that tree.
489   if (scalar @toplevel > 0) {
490     my @subs_found = recursive_find_directories(@toplevel);
491     push(@to_return, @subs_found);
492   }
493   return @to_return;
494 }
495
496 ############################################################################
497
498 1;
499