summaryrefslogtreecommitdiff
path: root/Build/tools/FileUtils.pm
diff options
context:
space:
mode:
Diffstat (limited to 'Build/tools/FileUtils.pm')
-rw-r--r--Build/tools/FileUtils.pm991
1 files changed, 991 insertions, 0 deletions
diff --git a/Build/tools/FileUtils.pm b/Build/tools/FileUtils.pm
new file mode 100644
index 00000000000..2b0bacd9c28
--- /dev/null
+++ b/Build/tools/FileUtils.pm
@@ -0,0 +1,991 @@
+# $Id$
+# Written 2004, Fabrice Popineau.
+# Public domain.
+#
+package FileUtils;
+
+BEGIN {
+ use Exporter ();
+ use Cwd;
+ use File::Path;
+ # use File::Copy qw(copy);
+ use vars qw( @ISA @EXPORT_OK);
+ if ($^O eq 'MSWin32')
+ { $Separator = "\\" ;}
+ else
+ { $Separator = "/" ;}
+
+ @ISA = qw(Exporter);
+
+ @EXPORT_OK = qw(
+ &basename
+ &build_path
+ &build_tree
+ &calc_file_size
+ &canon_dir
+ &check_path
+ &cleandir
+ &set_file_time
+ &copy
+ &diff_list
+ &dirname
+ &globexpand
+ &is_absolute
+ &is_dirsep
+ &look_for
+ &make_link
+ &member
+ &min max
+ &move
+ &newer
+ &newpath
+ &normalize
+ &print_tree
+ &push_uniq
+ &rec_copy
+ &rec_mkdir
+ &rec_rmdir
+ &regexpify
+ &remove_list
+ &sort_uniq
+ &start_redirection
+ &stop_redirection
+ &substitute_var_val
+ &sync_dir
+ &walk_dir
+ &walk_tree
+ );
+}
+
+# Is the character a directory separator ?
+sub is_dirsep {
+ my ($c) = @_;
+ if ($c =~ /[\/\\]/) {
+ return 1;
+ } else {
+ return 0;
+ }
+}
+
+# Is the path absolute ?
+sub is_absolute {
+ my ($d) = @_;
+ if ($d =~ m@^([A-Za-z]:)?[/\\]@) {
+ return 1;
+ } else {
+ return 0;
+ }
+}
+
+# Rewrite '\\' into '/' and deletes multiple ones/
+sub canon_dir {
+ my ($p, $rep) = @_;
+ if ($p =~ m@^(.*)[/\\]$@) {
+ $p = $1;
+ }
+ if (($rep eq '') || ($rep eq '\\')) {
+ $p =~ s@/@\\@g;
+ $p =~ s@\\[\\]+@\\@g;
+ $p =~ s@\\\.\\@\\@g;
+ while ($p =~ m/\\\.\./) {
+ $p =~ s@\\([^\\]+)\\\.\.@\\@g;
+ $p =~ s@\\[\\]+@\\@g;
+ }
+ } elsif ($rep eq '/') {
+ $p =~ s@\\@/@g;
+ $p =~ s@/[/]+@/@g;
+ $p =~ s@/\./@/@g;
+ while ($p =~ m/\/\.\./) {
+ $p =~ s@/([^/]+)/\.\.@/@g;
+ $p =~ s@/[/]+@/@g;
+ }
+ } else {
+ die ("canon_dir($p) : invalid separator $rep.\n");
+ }
+ return $p;
+}
+
+# Merges all elements in the list into a single path, adding
+# directory separators as needed.
+sub build_path {
+ my($p, $s);
+ # Concatenates the arguments, adding path separators as needed
+ $p = $_[0];
+ for ($i = 1; $i <= $#_; $i++) {
+ $p = $p . $Separator . $_[$i];
+ }
+ return &canon_dir($p);
+}
+
+sub sort_uniq {
+ my (@l) = @_;
+ my ($e, $f, @r);
+ @l = sort(@l);
+ foreach $e (@l) {
+ if ($e ne $f) {
+ $f = $e;
+ push @r, $e;
+ }
+ }
+ return @r;
+}
+
+sub remove_list {
+ local (*l, $e) = @_;
+ my (@r, $f);
+ foreach $f (@l) {
+ if ($f !~ m/$e/) {
+ push @r, $f;
+ }
+ }
+ @l = @r;
+}
+
+sub member {
+ my ($e, @l) = @_;
+ my ($f);
+ foreach $f (@l) {
+ if ($e eq $f) {
+ return 1;
+ }
+ }
+ return 0;
+}
+
+sub push_uniq {
+ local (*l, @le) = @_;
+ my ($e);
+ foreach $e (@le) {
+ if (! &member($e, @l)) {
+ push @l, $e;
+ }
+ }
+}
+
+sub dirname {
+ my ($f) = @_;
+ $f =~ m@(^.*)[\\/][^\\/]*$@;
+ return $1;
+}
+
+sub basename {
+ my ($f) = @_;
+ $f =~ m@([^\\/]*)$@;
+ return $1;
+}
+
+sub normalize {
+ my ($p, $sep) = @_;
+ if ($sep eq '/') {
+ $p =~ s@\\@/@g;
+ $p =~ s@/(/|\./)*@/@g;
+ return $p;
+ } elsif ((! $sep) || ($sep eq '\\')) {
+ $p =~ s@/@\\@g;
+ $p =~ s@\\(\\|\.\\)*@\\@g;
+ return $p;
+ } else {
+ print STDERR "normalize : invalid separator, $sep\n";
+ return $p;
+ }
+}
+
+sub walk_dir {
+ # Walks the directory, executing $proc for each file,
+ # until done is returned.
+ my ($dir, $proc, $prune) = @_;
+ my (@l, $f, $done, $src, $DIR);
+
+ print " walking $dir with $proc, $prune\n" if $::opt_debug;
+
+ if ((! $prune) || ($prune && ! &{$prune}($dir))) {
+ $done = 0;
+ # Walk the directory tree
+ opendir (DIR, $dir) || die "opendir($dir) failed: $!";
+ while (my $d = readdir (DIR)) {
+ # do not forget to remove "." and ".."
+ next if $d =~ /^\.(\.?|svn)$/;
+ push (@l, $d);
+ }
+ closedir (DIR) || warn "closedir($dir) failed: $!";
+
+ # top-down
+ &{$proc}($dir, @l);
+
+ foreach $f (@l) {
+ my $try = $dir . $Separator . $f;
+ # Don't descend symlinks, since they are only used for generic
+ # architecture names in bin. The tpm files use the real arch
+ # directory names (with system version numbers).
+ if (-d $try && ! -l $try) {
+ &walk_dir($try, $proc, $prune);
+ }
+ }
+ }
+}
+
+# Builds up a tree from pathes
+# $node is a reference to a hash
+sub build_tree {
+ my (@elts) = @_;
+ my $node = { };
+ foreach my $p (@elts) {
+ &add_path_to_tree($node, split("[/\\\\]", $p));
+ }
+ return $node;
+}
+
+sub add_path_to_tree {
+ my ($node, @path) = @_;
+ my ($current);
+
+ while (@path) {
+ $current = shift @path;
+ if ($$node{$current}) {
+ $node = $$node{$current};
+ } else {
+ $$node{$current} = { };
+ $node = $$node{$current};
+ }
+ }
+ return $node;
+}
+
+# walks the tree, calling the function at each node
+sub walk_tree {
+ local (@stack_dir);
+ walk_tree1(@_);
+}
+
+sub walk_tree1 {
+ my ($node, $pre_proc, $post_proc) = @_;
+ for $k (keys(%{$node})) {
+ push @stack_dir, $k;
+ $v = $node->{$k};
+ if ($pre_proc) { &{$pre_proc}($v, @stack_dir) }
+ walk_tree1 (\%{$v}, $pre_proc, $post_proc);
+ $v = $node->{$k};
+ if ($post_proc) { &{$post_proc}($v, @stack_dir) }
+ pop @stack_dir;
+ }
+}
+
+sub print_node {
+ my ($node, @stackdir) = @_;
+ if (! keys(%{$node})) {
+ print join("/", @stackdir) . "\n";
+ }
+}
+
+sub print_tree {
+ my ($node) = @_;
+ &walk_tree($node, \&print_node);
+}
+
+sub node2list {
+ my ($node, @stackdir) = @_;
+ if (! keys(%{$node})) {
+ push @list, join("/", @stackdir);
+ }
+}
+
+sub tree2list {
+ my ($node) = @_;
+ local @list;
+ &walk_tree($node, \&node2list);
+ return @list;
+}
+
+# Check that a path exists in a tree
+# exactly or as a subpath
+sub check_path {
+ my ($node, @path, $exact) = @_;
+ my ($current);
+ # print "Checking for " . join('/', @path) . " exact = $exact\n";
+ while (@path) {
+ $current = shift @path;
+ if ($$node{$current} == undef) {
+ return 0;
+ } else {
+ $node = $$node{$current};
+ }
+ }
+ # print "left " . join('/', @path) . " leaf " . $#{keys %{$node}} . "\n";
+ if ($exact) {
+ # We are at a leaf !
+ return ($#{keys %{$node}} == -1);
+ } else {
+ return 1;
+ }
+}
+
+
+
+# Removes everything in the directory
+# Can't use walk_dir because it could not remove directories.
+sub cleandir {
+ my ($dir)= @_;
+ my ($DIR, $f, @l, $name);
+
+ if (-d $dir) {
+ opendir DIR, "$dir";
+ # do not forget to remove "." and ".."
+ @l = readdir (DIR); shift @l; shift @l;
+ closedir DIR;
+ foreach $f (@l) {
+ $name = $dir . $Separator . $f;
+ if (-d $name) {
+ &rmtree($name);
+ print "rmdir $name\n" if $opt_verbose;
+ rmdir "$name";
+ } elsif (-f "$name") {
+ print "Removing $name\n" if $opt_verbose;
+ unlink "$name";
+ } else {
+ print "Can't remove $name!\n";
+ }
+ }
+ }
+}
+
+sub rec_rmdir {
+ my (@files) = @_;
+ map { &cleandir($_); rmdir($_) } @files;
+}
+
+# Builds up a new directory together with any of its parents
+sub rec_mkdir {
+ my ($path) = @_;
+ my $tmp;
+ my $old_dir = &getcwd;
+ my @l = split ("[/\\\\]", $path);
+ if ($path =~ m@[/\\]@) {
+ chdir "/"; shift @l;
+ }
+ elsif ($l[0] =~ m/[A-Za-z]:/) {
+ chdir "$l[0]/";
+ shift @l;
+ }
+ while (@l) {
+ $tmp = shift(@l);
+ mkdir($tmp, 755) if (! -d $tmp);
+ print "mkdir $tmp\n";
+ chdir $tmp;
+ }
+ chdir $old_dir;
+}
+
+sub copy {
+ my (@src, $dest, $l, $t);
+ @l = @_;
+ $dest = pop @l;
+
+ @src = ();
+ if ($#l == 0 && -f $l[0]) {
+ @src = @l;
+ }
+ else {
+ map {
+ my @expand = ($_ =~ m/ / ? <"$_"> : <$_>);
+# print "expanding $_ => @expand\n";
+ push @src, @expand;
+ } @l;
+ }
+ my $target;
+ map {
+ if (! -d $_) {
+ open IN, "<$_";
+ $target = $dest;
+ if (-d $target) {
+ $target = &newpath($dest, &basename($_));
+ }
+ open OUT, ">$target";
+
+# print "Copying $_ to " . &newpath($dest, &basename($_)) . "\n";
+ binmode(IN);
+ binmode(OUT);
+ print OUT <IN>;
+ close(OUT);
+ close(IN);
+ &set_file_time($_, $target);
+ }
+ } @src;
+}
+
+sub set_file_time {
+ my ($from, $to) = @_;
+ @st = stat($from);
+ utime($st[8], $st[9], $to);
+}
+
+sub rec_copy {
+ my (@src, $dest, $l, $dir);
+ @l = @_;
+ $dest = pop @l;
+
+ @src = ();
+ map {
+ my @expand = ($_ =~ m/ / ? <"${_}"> : <${_}>);
+# print "expanding $_ => @expand\n";
+ push @src, @expand;
+ } @l;
+
+ if (! -d $dest) {
+ mkdir ($dest, 777);
+ }
+
+ $dir = &getcwd;
+ if (! is_absolute($dest) ) {
+ $dest = &canon_dir("$dir/$dest");
+ print "new dest = $dest\n";
+ }
+
+ map {
+ $l = $_;
+ if (-d $l) {
+ chdir($l);
+ &rec_copy("*", "$dest/" . &basename($l));
+ chdir($dir);
+ } else {
+ &copy($l, "$dest/" . &basename($l));
+ &set_file_time($l, "$dest/" . &basename($l));
+ }
+ } @src;
+}
+
+sub move {
+ my ($dest) = pop @_;
+ my ($src, $f, $l);
+
+ @l = @_;
+ foreach $f (@l) {
+ # Handle globbing
+ if ($f =~ m/[*?]/) {
+ my @expand = ($f =~ m/ / ? <"${f}"> : <${f}>);
+# print "expanding $f => @expand\n";
+ push @src, @expand;
+ } else {
+ push @src, $f;
+ }
+ }
+ if (($#src > 2) && (! -d $dest)) {
+ print STDERR "*** Move : can't move to $dest, not a directory.\n";
+ return;
+ }
+
+ foreach $f (@src) {
+ if (-d $dest) {
+ rename($f, &newpath($dest, &basename($f)));
+ } else {
+ &copy($f, $dest);
+ &set_file_time($f, $dest);
+ unlink($f);
+ }
+ }
+}
+
+# Simulate links by copying
+sub make_link {
+ my ($to, $from) = @_;
+ $to = canon_dir($to);
+ $from = &newpath(dirname($to), $from);
+ print "linking $from -> $to ...";
+ if (-e $to) {
+ unlink($to);
+ }
+ if (-d $from) {
+ system("xcopy $from $to /f/r/i/e/d/k");
+ } else {
+ &copy($from, $to);
+ &set_file_time($from, $to);
+ }
+ print " done\n";
+}
+
+# Merges all elements in the list into a single path, adding
+# directory separators as needed.
+sub newpath {
+ return &canon_dir(join ($Separator, @_));
+}
+
+#
+# Search for $key = $val in $file
+#
+sub look_for {
+ my($key, $file) = @_;
+ my($ret);
+ open FIN, "<$file";
+ while (<FIN>) {
+ if ($_ =~ m/^$key\s*=\s*(\S*)/) {
+ $ret = $1;
+ last;
+ } elsif (/^\#define\s+$key\s+(\S*)/) {
+ $ret = $1;
+ last;
+ }
+ }
+ close FIN;
+ return $ret;
+}
+
+
+sub max {
+ $m = shift;
+ while ($_ = shift) {
+ $m = $_ if ($_ > $m);
+ }
+ return $m;
+}
+
+sub min {
+ $m = shift;
+ while ($_ = shift) {
+ $m = $_ if ($_ < $m);
+ }
+ return $m;
+}
+
+# Changes lines of the form:
+# $var=... to
+# $var='$val' in $file
+#
+sub substitute_var_val {
+ my($file, $var, $val) = @_;
+ my($success);
+
+ @success = ( );
+
+ if (! -f $file) {
+ print STDERR "$0: $file is not a file\n";
+ return $success;
+ }
+ open IN, "<$file";
+ open OUT, ">$file.bak";
+
+ while (<IN>) {
+ s/^$var\s*=\s*(.*)$/do {
+ push @success, $1;
+ # "\$" . $var . "=" . eval('$val') . ";" .
+ "$var = $val"
+ }/e;
+ print OUT;
+ }
+ close IN;
+ close OUT;
+
+ &copy("$file.bak", "$file");
+ unlink("$file.bak");
+
+ return @success;
+}
+
+#
+# Used by globexpand($recurse, $dir)
+#
+sub globexpand_push {
+ my ($dir, @l) = @_;
+ #print "globexpand_push($dir, @l)\n" if $::opt_debug;
+ my ($file);
+ $dir =~ s@\\@/@g;
+ foreach $file (@l) {
+ next if $file =~ /^\.(\.?|svn)$/;
+ my $path = "$dir/$file";
+ next if $path =~ m/^${Tpm::IgnoredFiles}$/;
+ if (-f $path) {
+ #print " push $dir/$file\n" if $::opt_debug;
+ push @listglob, $path;
+ }
+ }
+}
+
+#
+# Returns the list of files that match $pattern
+# Recursively walking directories if $recurse
+#
+sub globexpand {
+ my ($recurse, $pattern) = @_;
+ local @listglob = ( );
+# $opt_verbose = ($pattern =~ m/GsTools/i ? 1 : 0);
+ if (-f $pattern) {
+ push @listglob, $pattern;
+ }
+ else {
+ my @expand = ($pattern =~ m/ / ? <"${pattern}"> : <${pattern}>);
+ #print " globexpanding $pattern => @expand\n" if $::opt_debug;
+ while ( @expand ) {
+ $_ = shift @expand;
+ #print "elt $_\n" if $::opt_debug;
+ if (-f $_) {
+ #print " pushing $_\n" if $::opt_debug;
+ push @listglob, $_;
+ } elsif (($_ ne "") && (-d $_) && ($recurse)) {
+ &walk_dir($_, \&globexpand_push);
+ }
+ }
+ }
+ #print " globexpanded $pattern => @listglob\n" if $::opt_debug;
+ return @listglob;
+}
+
+sub diff_list {
+ local ($l1, $l2, *l1_l2, *l2_l1) = @_;
+
+ # print "Before sorting:\n";
+ # map { print "$_\n"; } @$l1;
+ # print "\n";
+ # map { print "$_\n"; } @$l2;
+ # $opt_verbose = 1;
+ # $opt_debug = 1;
+
+ @l1 = sort(@$l1);
+ @l2 = sort(@$l2);
+
+ # print "After sorting:\n";
+ # map { print "$_\n"; } @l1;
+ # print "\n";
+ # map { print "$_\n"; } @l2;
+
+ while ($#l1 >= 0 || $#l2 >= 0) {
+ if ($#l1 == -1) {
+ print "No more elements in l1, over.\n" if $opt_debug;
+ push (@l2_l1, @l2);
+ @l2 = ();
+ } elsif ($#l2 == -1) {
+ print "No more elements in l2, over.\n" if $opt_debug;
+ push (@l1_l2, @l1);
+ @l1 = ();
+ } else {
+ my $comp = $l1[0] cmp $l2[0];
+
+ if ($comp == 0) {
+ print "Same element $l1[0], shifting both.\n" if $opt_debug;
+ shift @l1;
+ shift @l2;
+ } elsif ($comp > 0) {
+ print "Greater element $l1[0] than $l2[0], shifting l2.\n" if $opt_debug;
+ push (@l2_l1, shift @l2);
+ } else {
+ print "Smaller element $l1[0] than $l2[0], shifting l1.\n" if $opt_debug;
+ push (@l1_l2, shift @l1);
+ }
+ }
+ }
+
+ if ($opt_verbose) {
+ print "$#l1_l2, $#l2_l1\n";
+
+ print "Elts in l1 and not in l2 : \n";
+ map { print "$_\n"; } @l1_l2; print "\n";
+
+ print "Elts in l2 and not in l1 : \n";
+ map { print "$_\n"; } @l2_l1; print "\n";
+ }
+ return ($#l1_l2 == -1 && $#l2_l1 == -1);
+}
+
+sub sync_dir {
+ my ($src, $dst, $opt_proc, $opt_prune, $opt_dry, $opt_mirror, $opt_nomkdir) = @_;
+ local ($cwd, $dry, $mirror, $proc, $prune, $nomkdir);
+
+ $cwd = &getcwd;
+ $dry = $opt_dry;
+ $mirror = $opt_mirror;
+ $proc = $opt_proc;
+ $prune = $opt_prune;
+ $nomkdir = $opt_nomkdir;
+
+ print "src = $src\ndst = $dst\n";
+ if (! chdir($src)) {
+ print "Error: can't chdir to $src\n";
+ return;
+ }
+ sync_dir_1(".", $dst);
+ chdir($cwd);
+}
+
+sub newer {
+ my ($f1, $f2) = @_;
+ my (@t1, @t2, $t11, $t12);
+ @t1 = stat($f1);
+ @t2 = stat($f2);
+ $t11 = $t1[9];
+ $t12 = $t2[9];
+ return -1 if ($t11 < $t12);
+ return 1 if ($t11 > $t12);
+ return 0;
+}
+
+sub sync_dir_1 {
+ # Walks the directory, executing $proc for each file,
+ # until done is returned.
+ my ($dir, $dst) = @_;
+ my (@l, $f, $done, $src, $DIR);
+
+ print "Walking $dir\n" if $opt_verbose;
+
+ if (! -d $dst) {
+ if (-f $dst) {
+ # Clash
+ print "!!!Clash: $dir is a directory and $dst is a file.\n";
+ return;
+ } elsif (! $nomkdir) {
+ print "Creating missing directory $dst\n";
+ mkdir $dst if (! $dry);
+ }
+ }
+
+ if ((! $prune) || ($prune && ! &{$prune}($dir))) {
+ $done = 0;
+ # Walk the directory tree
+ opendir DIR, "$dir";
+ # do not forget to remove "." and ".."
+ @l = readdir (DIR); shift @l; shift @l;
+ closedir DIR;
+ # Apply the filter
+ @l = &{$proc}($dir, $dst, @l) if ($proc);
+
+ foreach $f (@l) {
+ if (-d $dir . $Separator . $f) {
+ # source is directory
+ &sync_dir_1($dir . $Separator . $f, $dst . $Separator . $f);
+ } elsif (-d $dst . $Separator . $f) {
+ # source is file and destination is directory
+ print "!!!Clash: $dir is a file and $dst is a directory.\n";
+ next;
+ } elsif (! -f $dst . $Separator . $f) {
+ # source is file and destination is missing
+ print "Copying missing file " . $dst . $Separator . $f . "\n";
+ if (! $dry) {
+ &copy ($dir . $Separator . $f, $dst . $Separator . $f);
+ &set_file_time($dir . $Separator . $f, $dst . $Separator . $f);
+ }
+ } else {
+ my $compare = &newer($dir . $Separator . $f, $dst . $Separator . $f);
+ if ($compare > 0 || ($mirror && $compare < 0)) {
+ # source is file and destination is older than source
+ print "Copying newer file " . $dir . $Separator . $f . " than " . $dst . $Separator . $f . "\n";
+ if (! $dry) {
+ &copy ($dir . $Separator . $f, $dst . $Separator . $f);
+ &set_file_time($dir . $Separator . $f, $dst . $Separator . $f);
+ }
+ }
+ }
+ }
+ # Look at the other side
+ opendir DIR, "$dst";
+ # do not forget to remove "." and ".."
+ @l = readdir (DIR); shift @l; shift @l;
+ closedir DIR;
+ # Apply the same filter procedure
+ @l = &{$proc}($dir, $dst, @l) if ($proc);
+ foreach $f (@l) {
+ # We should look only for things to remove on the destination side
+ next if (-e "$dir$Separator$f");
+ # If it does not exist on the source side, then remove it.
+ if (-d "$dst$Separator$f") {
+ print "Removing directory $dst$Separator$f\n";
+ &rmtree("$dst$Separator$f") if (! $dry);
+ } elsif (-f "$dst$Separator$f") {
+ print "Removing file $dst$Separator$f\n";
+ unlink("$dst$Separator$f") if (! $dry);
+ } else {
+ print "Unknown file type $f\n";
+ }
+ }
+ }
+}
+
+sub start_redirection {
+ local ($log) = @_;
+
+ # start redirection if asked
+ if ($log) {
+ print "Logging onto $log\n";
+ open(SO, ">&STDOUT");
+ open(SE, ">&STDERR");
+
+ close(STDOUT);
+ close(STDERR);
+
+ open(STDOUT, ">$log");
+ open(STDERR,">&STDOUT");
+
+ select(STDERR); $| = 1;
+ select(STDOUT); $| = 1;
+ }
+}
+
+sub stop_redirection {
+
+ local($log) = @_;
+
+ if ($log) {
+ close(STDOUT);
+ close(STDERR);
+ open(STDOUT, ">&SO");
+ open(STDERR, ">&SE");
+ }
+}
+
+sub calc_file_size {
+ my ($dir, @files) = @_;
+ my ($size, @st);
+
+ # print "calc_file_size : $dir, files = $#files\n"; # if $opt_debug;
+ if (! -d $dir) {
+ print STDERR "$0: $dir is not a directory!\n";
+ return 0;
+ }
+ $size = 0;
+ @files = map { &globexpand(1, "$dir/$_"); } @files;
+ map {
+ @st = stat($_);
+ $size += $st[7];
+ } @files;
+ # print "size = $size\n" if ($opt_debug);
+ return $size;
+}
+
+# sub globtest {
+# my ($s1, $s2) = @_;
+# my @l1 = reverse(split("\\/", $s1));
+# my @l2 = reverse(split("\\/", $s2));
+# my $match = 1;
+# # pop @l1; pop @l2;
+# my $debug = 0;
+# print "l1 = (@l1), l2 = (@l2)\n" if ($debug);
+
+# while ($match) {
+# my $e1 = pop @l1;
+# my $e2 = pop @l2;
+# print "e1 = $e1, e2 = $e2\n" if ($debug);
+# last if ($e1 eq "" && $e2 eq "");
+
+# next if ($e1 eq $e2);
+# if ($e1 eq "*") {
+# return 1 if ($#l1 < 0);
+# $e1 = pop @l1;
+# print "e1 = $e1 $#l1 " if ($debug);
+# do {
+# $e2 = pop @l2;
+# print "e2 = $e2 " if ($debug);
+# } while ($e1 ne $e2 && $#l2 >= 0);
+# print "\n" if ($debug);
+# return ($e1 eq $e2 ? 1 : 0) if ($#l2 < 0);
+# }
+# if ($e2 eq "*") {
+# return 1 if ($#l2 < 0);
+# $e2 = pop @l2;
+# do {
+# $e1 = pop @l1;
+# } while ($e2 ne $e1 && $#l1 >= 0);
+# return ($e1 eq $e2 ? 1 : 0) if ($#l1 < 0);
+# }
+# $match = ($e1 eq $e2 ? 1 : 0);
+# }
+# print "returning $match\n" if ($debug);
+# return $match;
+# }
+
+sub regexpify_node {
+ my ($node, @stackdir) = @_;
+ my $relative = join "/", @stackdir;
+
+ @l2 = keys(%{$node});
+ # remove directories
+ @l2 = grep { ! (keys %{$node->{$_}}) } @l2;
+ if (@l2) {
+ opendir DIR, "$dir/$relative";
+ # do not forget to remove "." and ".."
+ my @l = readdir (DIR); shift @l; shift @l;
+ closedir DIR;
+ @l = grep { ! -d "$dir/$relative/$_" } @l;
+ # compare @l and keys(%{$node})
+ my (@l3, @l4);
+ @l3 = ();
+ @l4 = ();
+ my $diff = &diff_list(\@l, \@l2, \@l3, \@l4);
+ if ($diff) {
+ foreach $k (keys(%{$node})) {
+ delete $$node{$k} if (! (keys %{$node->{$k}}));;
+ }
+ $$node{'*'} = { };
+ }
+ }
+ else {
+
+ }
+}
+
+sub regexpify_recursive_node {
+ my ($node, @stackdir) = @_;
+ my $relative = join "/", @stackdir;
+
+ @l2 = keys(%{$node});
+ if (@l2) {
+ opendir DIR, "$dir/$relative";
+ # do not forget to remove "." and ".."
+ my @l = readdir (DIR); shift @l; shift @l;
+ closedir DIR;
+ # compare @l and keys(%{$node})
+ my (@l3, @l4);
+ @l3 = ();
+ @l4 = ();
+ my $diff = &diff_list(\@l, \@l2, \@l3, \@l4);
+ if ($diff) {
+ my $test = 1;
+ foreach $k (keys(%{$node})) {
+ $test = $test && ! $node->{$k}->{'__noregexpify'};
+ }
+ if ($test) {
+ foreach $k (keys(%{$node})) {
+ delete $$node{$k};
+ }
+ $$node{'*'} = { };
+ }
+ } else {
+ $node->{'__noregexpify'} = 1;
+ }
+ }
+ else {
+
+ }
+}
+
+sub regexpify_cleanup {
+ my ($node, @stackdir) = @_;
+ if ($node->{'__noregexpify'}) {
+ delete $node->{'__noregexpify'};
+ }
+}
+
+sub regexpify {
+ my ($recursive, $texdir, @files) = @_;
+ my ($node);
+ local $dir = $texdir;
+
+ $node = &FileUtils::build_tree(@files);
+
+ if ($recursive) {
+ &FileUtils::walk_tree($node, '', \&regexpify_recursive_node);
+ &FileUtils::walk_tree($node, '', \&regexpify_cleanup);
+ }
+ else {
+ &FileUtils::walk_tree($node, '', \&regexpify_node);
+ }
+ return &FileUtils::tree2list($node);
+}
+
+# Print Perl backtrace, for debugging.
+sub backtrace {
+ my $subr;
+ my $stackframe = 0;
+ while (($pkg,$filename,$line,$subr) = caller ($stackframe)) {
+ print "$filename:$line: $pkg::$subr called\n";
+ $stackframe++;
+ }
+}
+
+END { }
+
+1;
generated by cgit v1.2.3 (git 2.39.1) at 2024-12-27 03:11:30 +0000