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