"Fossies" - the Fresh Open Source Software Archive 
Member "install-tl-20231127/tlpkg/TeXLive/TLTREE.pm" (20 Feb 2023, 16138 Bytes) of package /linux/misc/install-tl-unx.tar.gz:
As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style:
standard) with prefixed line numbers and
code folding option.
Alternatively you can here
view or
download the uninterpreted source code file.
1 # $Id: TLTREE.pm 65994 2023-02-20 23:40:00Z karl $
2 # TeXLive::TLTREE.pm - work with the tree of all files
3 # Copyright 2007-2023 Norbert Preining
4 # This file is licensed under the GNU General Public License version 2
5 # or any later version.
6
7 use strict; use warnings;
8
9 package TeXLive::TLTREE;
10
11 my $svnrev = '$Revision: 65994 $';
12 my $_modulerevision = ($svnrev =~ m/: ([0-9]+) /) ? $1 : "unknown";
13 sub module_revision { return $_modulerevision; }
14
15 =pod
16
17 =head1 NAME
18
19 C<TeXLive::TLTREE> -- TeX Live tree of all files
20
21 =head1 SYNOPSIS
22
23 use TeXLive::TLTREE;
24 my $tltree = TeXLive::TLTREE->new();
25
26 $tltree->init_from_svn();
27 $tltree->init_from_statusfile();
28 $tltree->init_from_files();
29 $tltree->init_from_git();
30 $tltree->init_from_gitsvn();
31 $tltree->print();
32 $tltree->find_alldirs();
33 $tltree->print_node();
34 $tltree->walk_tree();
35 $tltree->add_path_to_tree();
36 $tltree->file_svn_lastrevision();
37 $tltree->size_of();
38 $tltree->get_matching_files();
39 $tltree->files_under_path();
40 $tltree->svnroot();
41 $tltree->revision();
42 $tltree->architectures();
43
44 =head1 DESCRIPTION
45
46 DOCUMENTATION MISSING, SORRY!!!
47
48 =cut
49
50 use TeXLive::TLUtils;
51
52 sub new {
53 my $class = shift;
54 my %params = @_;
55 my $self = {
56 svnroot => $params{'svnroot'},
57 archs => $params{'archs'},
58 revision => $params{'revision'},
59 # private stuff
60 _allfiles => {},
61 _dirtree => {},
62 _dirnames => {},
63 _filesofdir => {},
64 _subdirsofdir => {},
65 };
66 bless $self, $class;
67 return $self;
68 }
69
70 sub init_from_svn {
71 my $self = shift;
72 die "undefined svn root" if !defined($self->{'svnroot'});
73 my @lines = `cd $self->{'svnroot'} && svn status -v`;
74 my $retval = $?;
75 if ($retval != 0) {
76 $retval /= 256 if $retval > 0;
77 tldie("TLTree: svn status -v returned $retval, stopping.\n");
78 }
79 $self->_initialize_lines(@lines);
80 }
81
82 sub init_from_statusfile {
83 my $self = shift;
84 die "need filename of svn status file" if (@_ != 1);
85 open(TMP,"<$_[0]") || die "open of svn status file($_[0]) failed: $!";
86 my @lines = <TMP>;
87 close(TMP);
88 $self->_initialize_lines(@lines);
89 }
90 sub init_from_files {
91 my $self = shift;
92 my $svnroot = $self->{'svnroot'};
93 my @lines = `find $svnroot`;
94 my $retval = $?;
95 if ($retval != 0) {
96 $retval /= 256 if $retval > 0;
97 tldie("TLTree: find $svnroot returned $retval, stopping.\n");
98 }
99 @lines = grep(!/\/\.svn/ , @lines);
100 @lines = map { s@^$svnroot@@; s@^/@@; " 1 1 dummy $_" } @lines;
101 $self->{'revision'} = 1;
102 $self->_initialize_lines(@lines);
103 }
104
105
106 sub init_from_git {
107 my $self = shift;
108 my $svnroot = $self->{'svnroot'};
109 my $retval = $?;
110 my %files;
111 my %deletedfiles;
112 my @lines;
113
114 my @foo = `cd $svnroot; git log --pretty=format:COMMIT=%h --no-renames --name-status`;
115 if ($retval != 0) {
116 $retval /= 256 if $retval > 0;
117 tldie("TLTree: git log in $svnroot returned $retval, stopping.\n");
118 }
119 chomp(@foo);
120
121 my $curcom = "";
122 my $rev = 0;
123 for my $l (@foo) {
124 if ($l eq "") {
125 $curcom = "";
126 next;
127 } elsif ($l =~ m/^COMMIT=([[:xdigit:]]*)$/) {
128 $curcom = $1;
129 $rev++;
130 next;
131 } else {
132 # output is
133 # STATUS FILENAME
134 # where STATUS is as follows:
135 # Added (A), Copied (C), Deleted (D), Modified (M), Renamed (R), have their type (i.e. regular file,
136 # symlink, submodule, ...) changed (T), are Unmerged (U), are Unknown (X), or have had their pairing Broken (B).
137 if ($l =~ m/^(A|C|D|M|R|T|U|X|B)\S*\s+(.*)$/) {
138 my $status = $1;
139 my $curfile = $2;
140 #
141 # check whether the file was already removed
142 if (!defined($files{$curfile}) && !defined($deletedfiles{$curfile})) {
143 # first occurrence of that file
144 if ($status eq "D") {
145 $deletedfiles{$curfile} = 1;
146 } else {
147 $files{$curfile} = $rev;
148 }
149 }
150 } else {
151 print STDERR "Unknown line in git output: >>$l<<\n";
152 }
153 }
154 }
155
156 # now reverse the order
157 for my $f (keys %files) {
158 my $n = - ( $files{$f} - $rev ) + 1;
159 # special case for TL: remove Master if it is present
160 $f =~ s!^Master/!!;
161 push @lines, " $n $n dummy $f"
162 }
163 # debug(join("\n", @lines));
164 # TODO needs to be made better!
165 $self->{'revision'} = $rev;
166 $self->_initialize_lines(@lines);
167 }
168
169 sub init_from_gitsvn {
170 my $self = shift;
171 my $svnroot = $self->{'svnroot'};
172 my @foo = `cd $svnroot; git log --pretty=format:%h --name-only`;
173 chomp(@foo);
174 my $retval = $?;
175 if ($retval != 0) {
176 $retval /= 256 if $retval > 0;
177 tldie("TLTree: git log in $svnroot returned $retval, stopping.\n");
178 }
179 my %com2rev;
180 my @lines;
181 my $curcom = "";
182 my $currev = "";
183 for my $l (@foo) {
184 if ($l eq "") {
185 $currev = "";
186 $curcom = "";
187 next;
188 }
189 if ($curcom eq "") {
190 # now we should get a commit!
191 # we could also pattern match on 8 hex digits, but that costs time!
192 $curcom = $l;
193 $currev = `git svn find-rev $curcom`;
194 chomp($currev);
195 if (!$currev) {
196 # found a commit without svn rev, try to find it under the parents
197 my $foo = $curcom;
198 my $nr = 0;
199 while (1) {
200 $foo .= "^";
201 $nr++;
202 my $tr = `git svn find-rev $foo`;
203 chomp($tr);
204 if ($tr) {
205 # we add the number of parents to the currev
206 $currev = $tr + $nr;
207 last;
208 }
209 }
210 }
211 $com2rev{$curcom} = $currev;
212 } else {
213 # we got a file name
214 push @lines, " $currev $currev dummy $l"
215 }
216 }
217 # TODO needs to be made better!
218 $self->{'revision'} = 1;
219 $self->_initialize_lines(@lines);
220 }
221
222 sub _initialize_lines {
223 my $self = shift;
224 my @lines = @_;
225 my %archs;
226 # we first chdir to the svn root, we need it for file tests
227 chomp (my $oldpwd = `pwd`);
228 chdir($self->svnroot) || die "chdir($self->{svnroot}) failed: $!";
229 foreach my $l (@lines) {
230 chomp($l);
231 next if $l =~ /^\?/; # ignore files not under version control
232 if ($l =~ /^(.)(.)(.)(.)(.)(.)..\s*(\d+)\s+([\d\?]+)\s+([\w\?]+)\s+(.+)$/){
233 $self->{'revision'} = $7 unless defined($self->{'revision'});
234 my $lastchanged = ($8 eq "?" ? 1 : $8);
235 my $entry = "$10";
236 next if ($1 eq "D"); # ignore files which are removed
237 next if -d $entry && ! -l $entry; # keep symlinks to dirs (bin/*/man),
238 # ignore normal dirs.
239 # collect architectures; bin/ has arch subdirs plus the plain man
240 # special case.
241 if ($entry =~ m,^bin/([^/]*)/, && $entry ne "bin/man") {
242 $archs{$1} = 1;
243 }
244 $self->{'_allfiles'}{$entry}{'lastchangedrev'} = $lastchanged;
245 $self->{'_allfiles'}{$entry}{'size'} = (lstat $entry)[7];
246 my $fn = TeXLive::TLUtils::basename($entry);
247 my $dn = TeXLive::TLUtils::dirname($entry);
248 add_path_to_tree($self->{'_dirtree'}, split("[/\\\\]", $dn));
249 push @{$self->{'_filesofdir'}{$dn}}, $fn;
250 } elsif ($l ne ' 1 1 dummy ') {
251 tlwarn("Ignoring svn status output line:\n $l\n");
252 }
253 }
254 # save list of architectures
255 $self->architectures(keys(%archs));
256 # now do some magic
257 # - create list of top level dirs with a list of full path names of
258 # the respective dir attached
259 $self->walk_tree(\&find_alldirs);
260
261 chdir($oldpwd) || die "chdir($oldpwd) failed: $!";
262 }
263
264 sub print {
265 my $self = shift;
266 $self->walk_tree(\&print_node);
267 }
268
269 sub find_alldirs {
270 my ($self,$node, @stackdir) = @_;
271 my $tl = $stackdir[-1];
272 push @{$self->{'_dirnames'}{$tl}}, join("/", @stackdir);
273 if (keys(%{$node})) {
274 my $pa = join("/", @stackdir);
275 push @{$self->{'_subdirsofdir'}{$pa}}, keys(%{$node});
276 }
277 }
278
279 sub print_node {
280 my ($self,$node, @stackdir) = @_;
281 my $dp = join("/", @stackdir);
282 if ($self->{'_filesofdir'}{$dp}) {
283 foreach my $f (@{$self->{'_filesofdir'}{$dp}}) {
284 print "dp=$dp file=$f\n";
285 }
286 }
287 if (! keys(%{$node})) {
288 print join("/", @stackdir) . "\n";
289 }
290 }
291
292 sub walk_tree {
293 my $self = shift;
294 my (@stack_dir);
295 $self->_walk_tree1($self->{'_dirtree'},@_, @stack_dir);
296 }
297
298 sub _walk_tree1 {
299 my $self = shift;
300 my ($node,$pre_proc, $post_proc, @stack_dir) = @_;
301 my $v;
302 for my $k (keys(%{$node})) {
303 push @stack_dir, $k;
304 $v = $node->{$k};
305 if ($pre_proc) { &{$pre_proc}($self, $v, @stack_dir) }
306 $self->_walk_tree1 (\%{$v}, $pre_proc, $post_proc, @stack_dir);
307 $v = $node->{$k};
308 if ($post_proc) { &{$post_proc}($self, $v, @stack_dir) }
309 pop @stack_dir;
310 }
311 }
312
313 sub add_path_to_tree {
314 my ($node, @path) = @_;
315 my ($current);
316
317 while (@path) {
318 $current = shift @path;
319 if ($$node{$current}) {
320 $node = $$node{$current};
321 } else {
322 $$node{$current} = { };
323 $node = $$node{$current};
324 }
325 }
326 return $node;
327 }
328
329 sub file_svn_lastrevision {
330 my $self = shift;
331 my $fn = shift;
332 if (defined($self->{'_allfiles'}{$fn})) {
333 return($self->{'_allfiles'}{$fn}{'lastchangedrev'});
334 } else {
335 return(undef);
336 }
337 }
338
339 sub size_of {
340 my ($self,$f) = @_;
341 if (defined($self->{'_allfiles'}{$f})) {
342 return($self->{'_allfiles'}{$f}{'size'});
343 } else {
344 return(undef);
345 }
346 }
347
348 # return a per-architecture hash ref for TYPE eq "bin",
349 # list ref for all others.
350 #
351 =pod
352
353 The function B<get_matching_files> takes as arguments the type of the pattern
354 (bin, src, doc, run), the pattern itself, the package name (without
355 .ARCH specifications), and an optional architecture.
356 It returns a list of files matching that pattern (in the case
357 of bin patterns for that arch).
358
359 =cut
360
361 sub get_matching_files {
362 my ($self, $type, $p, $pkg, $arch) = @_;
363 my $ARCH = $arch;
364 my $newp;
365 {
366 my $warnstr = "";
367 local $SIG{__WARN__} = sub { $warnstr = $_[0]; };
368 eval "\$newp = \"$p\"";
369 if (!defined($newp)) {
370 die "cannot set newp from p: p=$p, pkg=$pkg, arch=$arch, type=$type";
371 }
372 if ($warnstr) {
373 tlwarn("Warning `$warnstr' while evaluating: $p "
374 . "(pkg=$pkg, arch=$arch, type=$type), returning empty list\n");
375 return ();
376 }
377 }
378 return $self->_get_matching_files($type,$newp);
379 }
380
381
382 sub _get_matching_files {
383 my ($self, $type, $p) = @_;
384 my ($pattype,$patdata,@rest) = split ' ',$p;
385 my @matchfiles;
386 if ($pattype eq "t") {
387 @matchfiles = $self->_get_files_matching_dir_pattern($type,$patdata,@rest);
388 } elsif ($pattype eq "f") {
389 @matchfiles = $self->_get_files_matching_glob_pattern($type,$patdata);
390 } elsif ($pattype eq "r") {
391 @matchfiles = $self->_get_files_matching_regexp_pattern($type,$patdata);
392 } elsif ($pattype eq "d") {
393 @matchfiles = $self->files_under_path($patdata);
394 } else {
395 die "Unknown pattern type `$pattype' in $p";
396 }
397 ddebug("p=$p; matchfiles=@matchfiles\n");
398 return @matchfiles;
399 }
400
401 #
402 # we transform a glob pattern to a regexp pattern:
403 # currently supported globs: ? *
404 #
405 # sequences of subsitutions:
406 # . -> \.
407 # * -> .*
408 # ? -> .
409 # + -> \+
410 sub _get_files_matching_glob_pattern
411 {
412 my $self = shift;
413 my ($type,$globline) = @_;
414 my @returnfiles;
415
416 my $dirpart = TeXLive::TLUtils::dirname($globline);
417 my $basepart = TeXLive::TLUtils::basename($globline);
418 $basepart =~ s/\./\\./g;
419 $basepart =~ s/\*/.*/g;
420 $basepart =~ s/\?/./g;
421 $basepart =~ s/\+/\\+/g;
422 return unless (defined($self->{'_filesofdir'}{$dirpart}));
423
424 my @candfiles = @{$self->{'_filesofdir'}{$dirpart}};
425 for my $f (@candfiles) {
426 dddebug("matching $f in $dirpart via glob $globline\n");
427 if ($f =~ /^$basepart$/) {
428 dddebug("hit: globline=$globline, $dirpart/$f\n");
429 if ("$dirpart" eq ".") {
430 push @returnfiles, "$f";
431 } else {
432 push @returnfiles, "$dirpart/$f";
433 }
434 }
435 }
436
437 if ($dirpart =~ m,^bin/(windows|win[0-9]|.*-cygwin),
438 || $dirpart =~ m,tlpkg/installer,) {
439 # for windows-ish we want to automatch more extensions.
440 foreach my $f (@candfiles) {
441 my $w32_binext;
442 if ($dirpart =~ m,^bin/.*-cygwin,) {
443 $w32_binext = "exe"; # cygwin has .exe but nothing else
444 } else {
445 $w32_binext = "(exe|dll)(.manifest)?|texlua|bat|cmd";
446 }
447 ddebug("matching $f in $dirpart via glob $globline.($w32_binext)\n");
448 if ($f =~ /^$basepart\.($w32_binext)$/) {
449 ddebug("hit: globline=$globline, $dirpart/$f\n");
450 if ("$dirpart" eq ".") {
451 push @returnfiles, "$f";
452 } else {
453 push @returnfiles, "$dirpart/$f";
454 }
455 }
456 }
457 }
458 return @returnfiles;
459 }
460
461 sub _get_files_matching_regexp_pattern {
462 my $self = shift;
463 my ($type,$regexp) = @_;
464 my @returnfiles;
465 FILELABEL: foreach my $f (keys(%{$self->{'_allfiles'}})) {
466 if ($f =~ /^$regexp$/) {
467 TeXLive::TLUtils::push_uniq(\@returnfiles,$f);
468 next FILELABEL;
469 }
470 }
471 return(@returnfiles);
472 }
473
474 #
475 # go through all dir names in the TLTREE such that
476 # which are named like the last entry of @patwords,
477 # and which have initial path component of the
478 # rest of @patwords
479 #
480 # This is not optimal, because many subsetted
481 # dirs are found, example package graphics contains
482 # the following exception line to make sure that
483 # these files are not included.
484 # docpattern +!d texmf-dist/doc/latex/graphicxbox/examples/graphics
485 #
486 # We don't need *arbitrary* depth, because what can happen is
487 # that the autopattern
488 # docpattern Package t texmf-dist doc %NAME%
489 # can match at one of the following
490 # texmf-dist/doc/%NAME
491 # texmf-dist/doc/<SOMETHING>/%NAME
492 # but not deeper.
493 # Same for the others.
494 #
495 # Lets say that we try that <SOMETHING> contains at *most*
496 # one (1) / (forward slash/path separator)
497 #
498 # only for fonts we need a special treatment with 3
499 #
500 sub _get_files_matching_dir_pattern {
501 my ($self,$type,@patwords) = @_;
502 my $tl = pop @patwords;
503 my $maxintermediate = 1;
504 if (($#patwords >= 1 && $patwords[1] eq 'fonts')
505 ||
506 ($#patwords >= 2 && $patwords[2] eq 'context')) {
507 $maxintermediate = 2;
508 }
509 my @returnfiles;
510 if (defined($self->{'_dirnames'}{$tl})) {
511 foreach my $tld (@{$self->{'_dirnames'}{$tl}}) {
512 my $startstr = join("/",@patwords)."/";
513 if (index($tld, $startstr) == 0) {
514 my $middlepart = $tld;
515 $middlepart =~ s/\Q$startstr\E//;
516 $middlepart =~ s!/$tl/!!;
517 # put match into list context returns
518 # all matches, which is than coerced to
519 # an integer which gives the number!
520 my $number = () = $middlepart =~ m!/!g;
521 #printf STDERR "DEBUG: maxint=$maxintermediate, number=$number, patwords=@patwords\n";
522 if ($number <= $maxintermediate) {
523 my @files = $self->files_under_path($tld);
524 TeXLive::TLUtils::push_uniq(\@returnfiles, @files);
525 }
526 }
527 }
528 }
529 return(@returnfiles);
530 }
531
532 sub files_under_path {
533 my $self = shift;
534 my $p = shift;
535 my @files = ();
536 foreach my $aa (@{$self->{'_filesofdir'}{$p}}) {
537 TeXLive::TLUtils::push_uniq(\@files, $p . "/" . $aa);
538 }
539 if (defined($self->{'_subdirsofdir'}{$p})) {
540 foreach my $sd (@{$self->{'_subdirsofdir'}{$p}}) {
541 my @sdf = $self->files_under_path($p . "/" . $sd);
542 TeXLive::TLUtils::push_uniq (\@files, @sdf);
543 }
544 }
545 return @files;
546 }
547
548
549 #
550 # member access functions
551 #
552 sub svnroot {
553 my $self = shift;
554 if (@_) { $self->{'svnroot'} = shift };
555 return $self->{'svnroot'};
556 }
557
558 sub revision {
559 my $self = shift;
560 if (@_) { $self->{'revision'} = shift };
561 return $self->{'revision'};
562 }
563
564
565 sub architectures {
566 my $self = shift;
567 if (@_) { @{ $self->{'archs'} } = @_ }
568 return defined $self->{'archs'} ? @{ $self->{'archs'} } : ();
569 }
570
571 1;
572 __END__
573
574 =head1 SEE ALSO
575
576 The modules L<TeXLive::TLPSRC>, L<TeXLive::TLPOBJ>, L<TeXLive::TLPDB>,
577 L<TeXLive::TLUtils>, etc., and the documentation in the repository:
578 C<Master/tlpkg/doc/>.
579
580 =head1 AUTHORS AND COPYRIGHT
581
582 This script and its documentation were written for the TeX Live
583 distribution (L<https://tug.org/texlive>) and both are licensed under the
584 GNU General Public License Version 2 or later.
585
586 =cut
587
588 ### Local Variables:
589 ### perl-indent-level: 2
590 ### tab-width: 2
591 ### indent-tabs-mode: nil
592 ### End:
593 # vim:set tabstop=2 expandtab: #