1# $Id: TLTREE.pm 34045 2014-05-15 17:39:06Z karl $
2# TeXLive::TLTREE.pm - work with the tree of all files
3# Copyright 2007-2014 Norbert Preining
4# This file is licensed under the GNU General Public License version 2
5# or any later version.
6
7package TeXLive::TLTREE;
8
9my $svnrev = '$Revision: 34045 $';
10my $_modulerevision;
11if ($svnrev =~ m/: ([0-9]+) /) {
12  $_modulerevision = $1;
13} else {
14  $_modulerevision = "unknown";
15}
16sub module_revision {
17  return $_modulerevision;
18}
19
20use TeXLive::TLUtils;
21
22sub new {
23  my $class = shift;
24  my %params = @_;
25  my $self = {
26    svnroot   => $params{'svnroot'},
27    archs     => $params{'archs'},
28    revision  => $params{'revision'},
29    # private stuff
30    _allfiles   => {},
31    _dirtree    => {},
32    _dirnames   => {},
33    _filesofdir => {},
34    _subdirsofdir => {},
35  };
36  bless $self, $class;
37  return $self;
38}
39
40sub init_from_svn {
41  my $self = shift;
42  die "undefined svn root" if !defined($self->{'svnroot'});
43  my @lines = `cd $self->{'svnroot'} && svn status -v`;
44  my $retval = $?;
45  if ($retval != 0) {
46    $retval /= 256 if $retval > 0;
47    tldie("TLTree: svn status -v returned $retval, stopping.\n");
48  }
49  $self->_initialize_lines(@lines);
50}
51
52sub init_from_statusfile {
53  my $self = shift;
54  die "need filename of svn status file" if (@_ != 1);
55  open(TMP,"<$_[0]") || die "open of svn status file($_[0]) failed: $!";
56  my @lines = <TMP>;
57  close(TMP);
58  $self->_initialize_lines(@lines);
59}
60sub init_from_files {
61  my $self = shift;
62  my $svnroot = $self->{'svnroot'};
63  my @lines = `find $svnroot`;
64  my $retval = $?;
65  if ($retval != 0) {
66    $retval /= 256 if $retval > 0;
67    tldie("TLTree: find $svnroot returned $retval, stopping.\n");
68  }
69  @lines = grep(!/\/\.svn/ , @lines);
70  @lines = map { s@^$svnroot@@; s@^/@@; "             1 1 dummy $_" } @lines;
71  $self->{'revision'} = 1;
72  $self->_initialize_lines(@lines);
73}
74
75sub _initialize_lines {
76  my $self = shift;
77  my @lines = @_;
78  my %archs;
79  # we first chdir to the svn root, we need it for file tests
80  chomp (my $oldpwd = `pwd`);
81  chdir($self->svnroot) || die "chdir($self->{svnroot}) failed: $!";
82  foreach my $l (@lines) {
83    chomp($l);
84    next if $l =~ /^\?/;    # ignore files not under version control
85    if ($l =~ /^(.)(.)(.)(.)(.)(.)..\s*(\d+)\s+([\d\?]+)\s+([\w\?]+)\s+(.+)$/){
86      $self->{'revision'} = $7 unless defined($self->{'revision'});
87      my $lastchanged = ($8 eq "?" ? 1 : $8);
88      my $entry = "$10";
89      next if ($1 eq "D"); # ignore files which are removed
90      next if -d $entry && ! -l $entry; # keep symlinks to dirs (bin/*/man),
91                                        # ignore normal dirs.
92      # collect architectures, assuming nothing is in bin/ but arch subdirs.
93      if ($entry =~ m,^bin/([^/]*)/,) {
94        $archs{$1} = 1;
95      }
96      $self->{'_allfiles'}{$entry}{'lastchangedrev'} = $lastchanged;
97      $self->{'_allfiles'}{$entry}{'size'} = (lstat $entry)[7];
98      my $fn = TeXLive::TLUtils::basename($entry);
99      my $dn = TeXLive::TLUtils::dirname($entry);
100      add_path_to_tree($self->{'_dirtree'}, split("[/\\\\]", $dn));
101      push @{$self->{'_filesofdir'}{$dn}}, $fn;
102    } elsif ($l ne '             1 1 dummy ') {
103      tlwarn("Ignoring svn status output line:\n    $l\n");
104    }
105  }
106  # save list of architectures
107  $self->architectures(keys(%archs));
108  # now do some magic
109  # - create list of top level dirs with a list of full path names of
110  #   the respective dir attached
111  $self->walk_tree(\&find_alldirs);
112
113  chdir($oldpwd) || die "chdir($oldpwd) failed: $!";
114}
115
116sub print {
117  my $self = shift;
118  $self->walk_tree(\&print_node);
119}
120
121sub find_alldirs {
122  my ($self,$node, @stackdir) = @_;
123  my $tl = $stackdir[-1];
124  push @{$self->{'_dirnames'}{$tl}}, join("/", @stackdir);
125  if (keys(%{$node})) {
126    my $pa = join("/", @stackdir);
127    push @{$self->{'_subdirsofdir'}{$pa}}, keys(%{$node});
128  }
129}
130
131sub print_node {
132  my ($self,$node, @stackdir) = @_;
133  my $dp = join("/", @stackdir);
134  if ($self->{'_filesofdir'}{$dp}) {
135    foreach my $f (@{$self->{'_filesofdir'}{$dp}}) {
136      print "dp=$dp file=$f\n";
137    }
138  }
139  if (! keys(%{$node})) {
140    print join("/", @stackdir) . "\n";
141  }
142}
143
144sub walk_tree {
145  my $self = shift;
146  my (@stack_dir);
147  $self->_walk_tree1($self->{'_dirtree'},@_, @stack_dir);
148}
149
150sub _walk_tree1 {
151  my $self = shift;
152  my ($node,$pre_proc, $post_proc, @stack_dir) = @_;
153  my $v;
154  for my $k (keys(%{$node})) {
155    push @stack_dir, $k;
156    $v = $node->{$k};
157    if ($pre_proc) { &{$pre_proc}($self, $v, @stack_dir) }
158    $self->_walk_tree1 (\%{$v}, $pre_proc, $post_proc, @stack_dir);
159    $v = $node->{$k};
160    if ($post_proc) { &{$post_proc}($self, $v, @stack_dir) }
161    pop @stack_dir;
162  }
163}
164
165sub add_path_to_tree {
166  my ($node, @path) = @_;
167  my ($current);
168
169  while (@path) {
170    $current = shift @path;
171    if ($$node{$current}) {
172      $node = $$node{$current};
173    } else {
174      $$node{$current} = { };
175      $node = $$node{$current};
176    }
177  }
178  return $node;
179}
180
181sub file_svn_lastrevision {
182  my $self = shift;
183  my $fn = shift;
184  if (defined($self->{'_allfiles'}{$fn})) {
185    return($self->{'_allfiles'}{$fn}{'lastchangedrev'});
186  } else {
187    return(undef);
188  }
189}
190
191sub size_of {
192  my ($self,$f) = @_;
193  if (defined($self->{'_allfiles'}{$f})) {
194    return($self->{'_allfiles'}{$f}{'size'});
195  } else {
196    return(undef);
197  }
198}
199
200# return a per-architecture hash ref for TYPE eq "bin",
201# list ref for all others.
202#
203=pod
204
205The function B<get_matching_files> takes as arguments the type of the pattern
206(bin, src, doc, run), the pattern itself, the package name (without
207.ARCH specifications), and an optional architecture.
208It returns a list of files matching that pattern (in the case
209of bin patterns for that arch).
210
211=cut
212
213sub get_matching_files {
214  my ($self, $type, $p, $pkg, $arch) = @_;
215  my $ARCH = $arch;
216  my $PKGNAME = $pkg;
217  my $newp;
218  eval "\$newp = \"$p\"";
219  if (!defined($newp)) {
220    print "Huuu: cannot generate newp from p: p=$p, pkg=$pkg, arch=$arch, type=$type\n";
221  }
222  return($self->_get_matching_files($type,$newp));
223}
224
225
226sub _get_matching_files {
227  my ($self, $type, $p) = @_;
228  my ($pattype,$patdata,@rest) = split ' ',$p;
229  my @matchfiles;
230  if ($pattype eq "t") {
231    @matchfiles = $self->_get_files_matching_dir_pattern($type,$patdata,@rest);
232  } elsif ($pattype eq "f") {
233    @matchfiles = $self->_get_files_matching_glob_pattern($type,$patdata);
234  } elsif ($pattype eq "r") {
235    @matchfiles = $self->_get_files_matching_regexp_pattern($type,$patdata);
236  } elsif ($pattype eq "d") {
237    @matchfiles = $self->files_under_path($patdata);
238  } else {
239    die "Unknown pattern pattern type `$pattype' in $p";
240  }
241  ddebug("p=$p; matchfiles=@matchfiles\n");
242  return @matchfiles;
243}
244
245#
246# we transform a glob pattern to a regexp pattern:
247# currently supported globs: ? *
248#
249# sequences of subsitutions:
250#   . -> \.
251#   * -> .*
252#   ? -> .
253#   + -> \+
254sub _get_files_matching_glob_pattern
255{
256  my $self = shift;
257  my ($type,$globline) = @_;
258  my @returnfiles;
259
260  my $dirpart = TeXLive::TLUtils::dirname($globline);
261  my $basepart = TeXLive::TLUtils::basename($globline);
262  $basepart =~ s/\./\\./g;
263  $basepart =~ s/\*/.*/g;
264  $basepart =~ s/\?/./g;
265  $basepart =~ s/\+/\\+/g;
266  return unless (defined($self->{'_filesofdir'}{$dirpart}));
267
268  my @candfiles = @{$self->{'_filesofdir'}{$dirpart}};
269  for my $f (@candfiles) {
270    ddebug("matching $f in $dirpart via glob $globline\n");
271    if ($f =~ /^$basepart$/) {
272      ddebug("hit: globline=$globline, $dirpart/$f\n");
273      if ("$dirpart" eq ".") {
274        push @returnfiles, "$f";
275      } else {
276        push @returnfiles, "$dirpart/$f";
277      }
278    }
279  }
280
281  if ($dirpart =~ m,^bin/(win[0-9]|.*-cygwin),
282      || $dirpart =~ m,tlpkg/installer,) {
283    # for windows-ish we want to automatch more extensions.
284    foreach my $f (@candfiles) {
285      my $w32_binext;
286      if ($dirpart =~ m,^bin/.*-cygwin,) {
287        $w32_binext = "exe";  # cygwin has .exe but nothing else
288      } else {
289        $w32_binext = "(exe|dll)(.manifest)?|texlua|bat|cmd";
290      }
291      ddebug("matching $f in $dirpart via glob $globline.($w32_binext)\n");
292      if ($f =~ /^$basepart\.($w32_binext)$/) {
293        ddebug("hit: globline=$globline, $dirpart/$f\n");
294        if ("$dirpart" eq ".") {
295          push @returnfiles, "$f";
296        } else {
297          push @returnfiles, "$dirpart/$f";
298        }
299      }
300    }
301  }
302  return @returnfiles;
303}
304
305sub _get_files_matching_regexp_pattern {
306  my $self = shift;
307  my ($type,$regexp) = @_;
308  my @returnfiles;
309  FILELABEL: foreach my $f (keys(%{$self->{'_allfiles'}})) {
310    if ($f =~ /^$regexp$/) {
311      TeXLive::TLUtils::push_uniq(\@returnfiles,$f);
312      next FILELABEL;
313    }
314  }
315  return(@returnfiles);
316}
317
318sub _get_files_matching_dir_pattern {
319  my ($self,$type,@patwords) = @_;
320  my $tl = pop @patwords;
321  my @returnfiles;
322  if (defined($self->{'_dirnames'}{$tl})) {
323    foreach my $tld (@{$self->{'_dirnames'}{$tl}}) {
324      if (index($tld,join("/",@patwords)."/") == 0) {
325        my @files = $self->files_under_path($tld);
326        TeXLive::TLUtils::push_uniq(\@returnfiles, @files);
327      }
328    }
329  }
330  return(@returnfiles);
331}
332
333sub files_under_path {
334  my $self = shift;
335  my $p = shift;
336  my @files = ();
337  foreach my $aa (@{$self->{'_filesofdir'}{$p}}) {
338    TeXLive::TLUtils::push_uniq(\@files, $p . "/" . $aa);
339  }
340  if (defined($self->{'_subdirsofdir'}{$p})) {
341    foreach my $sd (@{$self->{'_subdirsofdir'}{$p}}) {
342      my @sdf = $self->files_under_path($p . "/" . $sd);
343      TeXLive::TLUtils::push_uniq (\@files, @sdf);
344    }
345  }
346  return @files;
347}
348
349
350#
351# member access functions
352#
353sub svnroot {
354  my $self = shift;
355  if (@_) { $self->{'svnroot'} = shift };
356  return $self->{'svnroot'};
357}
358
359sub revision {
360  my $self = shift;
361  if (@_) { $self->{'revision'} = shift };
362  return $self->{'revision'};
363}
364
365
366sub architectures {
367  my $self = shift;
368  if (@_) { @{ $self->{'archs'} } = @_ }
369  return exists $self->{'archs'} ? @{ $self->{'archs'} } : undef;
370}
371
372
3731;
374
375### Local Variables:
376### perl-indent-level: 2
377### tab-width: 2
378### indent-tabs-mode: nil
379### End:
380# vim:set tabstop=2 expandtab: #
381