path: root/Master/tlpkg/TeXLive/TLTREE.pm

# $Id$
# TeXLive::TLTREE.pm - helper module to work with the tree of all files
# Copyright 2007 Norbert Preining
#
# This file is licensed under the GNU General Public License version 2
# or any later version.

package TeXLive::TLTREE;

use TeXLive::TLUtils;

sub new {
  my $class = shift;
  my %params = @_;
  my $self = {
    svnroot   => $params{'svnroot'},
    archs     => $params{'archs'},
    # private stuff
    _allfiles   => {},
    _dirtree    => {},
    _dirnames   => {},
    _filesofdir => {},
    _subdirsofdir => {},
  };
  bless $self, $class;
  return $self;
}

sub init_from_svn {
  my $self = shift;
  die("Undefined svn root!") if (!defined($self->{'svnroot'}));
  my @lines = `cd $self->{'svnroot'} && svn status -v`;
  $self->_initialize_lines(@lines);
}

sub init_from_statusfile {
  my $self = shift;
  die("Need a filename of svn status file!") if (@_ != 1);
  open(TMP,"<$_[0]") || die("Cannot open svn status file: $_[0]");
  my @lines = <TMP>;
  close(TMP);
  $self->_initialize_lines(@lines);
}
sub init_from_files {
  my $self = shift;
  my $svnroot = $self->{'svnroot'};
  my @lines = `find $svnroot ! -wholename '*/.svn*'`;
  @lines = map { s@^$svnroot@@; s@^/@@; "             1 1 dummy $_" } @lines;
  $self->_initialize_lines(@lines);
}

sub _initialize_lines {
  my $self = shift;
  my @lines = @_;
  my %archs;
  # we first chdir to the svn root, we need it for file tests
  my $oldpwd = `pwd`;
  chomp($oldpwd);
  chdir($self->svnroot) || die("Cannot chdir to SVN root $self->{'svnroot'}!");
  foreach my $l (@lines) {
    chomp($l);
    next if ($l =~ /^\?/);    # ignore files not under version control
    if ($l =~ /^(.)(.)(.)(.)(.)(.)..\s*(\d+)\s+([\d\?]+)\s+([\w\?]+)\s+(.+)$/) {
      my $lastchanged = ($8 eq "?" ? 1 : $8);
      my $entry = "$10";
      next if -d $entry;  # TODO: what to do with links???
      # collect architectures
      if ($entry =~ m,^bin/(.*)/tex.*$,) {
        $archs{$1} = 1;
      }
      $self->{'_allfiles'}{$entry}{'lastchangedrev'} = $lastchanged;
      $self->{'_allfiles'}{$entry}{'size'} = (lstat $entry)[7];
      my $fn = TeXLive::TLUtils::basename($entry);
      my $dn = TeXLive::TLUtils::dirname($entry);
      add_path_to_tree($self->{'_dirtree'}, split("[/\\\\]", $dn));
      push @{$self->{'_filesofdir'}{$dn}}, $fn;
    } else {
      warn("Ignoring svn status output line:\n    $l\n");
      #die("Cannot read svn status output line:\n    $l\n");
    }
  }
  # save list of architectures
  $self->architectures(keys(%archs));
  # now do some magic
  # - create list of top level dirs with a list of full path names of
  #   the respective dir attached
  $self->walk_tree(\&find_alldirs);
  chdir($oldpwd);
}

sub print {
  my $self = shift;
  $self->walk_tree(\&print_node);
}

sub find_alldirs {
  my ($self,$node, @stackdir) = @_;
  my $tl = $stackdir[-1];
  push @{$self->{'_dirnames'}{$tl}}, join("/", @stackdir);
  if (keys(%{$node})) {
    my $pa = join("/", @stackdir);
    push @{$self->{'_subdirsofdir'}{$pa}}, keys(%{$node});
  }
}

sub print_node {
  my ($self,$node, @stackdir) = @_;
  my $dp = join("/", @stackdir);
  if ($self->{'_filesofdir'}{$dp}) {
    foreach my $f (@{$self->{'_filesofdir'}{$dp}}) {
      print "dp=$dp file=$f\n";
    }
  }
  if (! keys(%{$node})) {
    print join("/", @stackdir) . "\n";
  }
}

sub walk_tree {
  my $self = shift;
  my (@stack_dir);
  $self->_walk_tree1($self->{'_dirtree'},@_, @stack_dir);
}

sub _walk_tree1 {
  my $self = shift;
  my ($node,$pre_proc, $post_proc, @stack_dir) = @_;
  my $v;
  for my $k (keys(%{$node})) {
    push @stack_dir, $k;
    $v = $node->{$k};
    if ($pre_proc) { &{$pre_proc}($self, $v, @stack_dir) }
    $self->_walk_tree1 (\%{$v}, $pre_proc, $post_proc, @stack_dir);
    $v = $node->{$k};
    if ($post_proc) { &{$post_proc}($self, $v, @stack_dir) }
    pop @stack_dir;
  }
}

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;
}

sub file_svn_lastrevision {
  my $self = shift;
  my $fn = shift;
  if (defined($self->{'_allfiles'}{$fn})) {
    return($self->{'_allfiles'}{$fn}{'lastchangedrev'});
  } else {
    return(undef);
  }
}

sub size_of {
  my ($self,$f) = @_;
  if (defined($self->{'_allfiles'}{$f})) {
    return($self->{'_allfiles'}{$f}{'size'});
  } else {
    return(undef);
  }
}

sub get_matching_files {
  my ($self, $type, $p) = @_;
  if ($type eq "bin") {
    # we first substitute arch for ${ARCH}
    my %returnfiles;
    foreach $a ($self->architectures) {
      # return empty list of arch!=win32 and pattern matches bin/win32
      if (($p =~ m@f bin/win32/@) && ($a ne "win32")) {
        $returnfiles{$a} = [ ];
        next;
      }
      my $ARCH = $a;
      my $newp;
      eval "\$newp = \"$p\"";
      my @foo = $self->_get_matching_files($type,$newp);
      $returnfiles{$a} = [ @foo ];
    }
    return(\%returnfiles);
  } else {
    my @returnfiles = $self->_get_matching_files($type,$p);
    return(\@returnfiles);
  }
}

  
sub _get_matching_files {
  my ($self, $type, $p) = @_;
  my ($pattype,$patdata,@rest) = split ' ',$p;
  my @matchfiles;
  if ($pattype eq "t") {
    @matchfiles = $self->_get_files_matching_dir_pattern($type,$patdata,@rest);
  } elsif ($pattype eq "f") {
    @matchfiles = $self->_get_files_matching_glob_pattern($type,$patdata,$arch);
  } elsif ($pattype eq "r") {
    @matchfiles = $self->_get_files_matching_regexp_pattern($type,$patdata);
  } elsif ($pattype eq "d") {
    @matchfiles = $self->files_under_path($patdata);
  } else {
    die "Unknown pattern $p";
  }
  TeXLive::TLUtils::debug("p=$p; matchfiles=@matchfiles");
  return @matchfiles;
}

#
# we transform a glob pattern to a regexp pattern:
# currently supported globs: ? *
#
# sequences of subsitutions:
#   . -> \.
#   * -> .*
#   ? -> .
#   + -> \+
sub _get_files_matching_glob_pattern {
  my $self = shift;
  my ($type,$globline) = @_;
  my @returnfiles;
  my $dirpart = TeXLive::TLUtils::dirname($globline);
  my $basepart = TeXLive::TLUtils::basename($globline);
  $basepart =~ s/\./\\./g;
  $basepart =~ s/\*/.*/g;
  $basepart =~ s/\?/./g;
  $basepart =~ s/\+/\\+/g;
  return unless (defined($self->{'_filesofdir'}{$dirpart}));
  my @candfiles = @{$self->{'_filesofdir'}{$dirpart}};
  foreach my $f (@candfiles) {
    &TeXLive::TLUtils::debug("matching $f in $dirpart via glob $globline");
    if ($f =~ /^$basepart$/) {
      &TeXLive::TLUtils::debug("hit: globline=$globline, $dirpart/$f");
      push @returnfiles, "$dirpart/$f";
    }
  }
  if ($dirpart =~ m@^bin/win32@) {
    # for arch=win32 under bin we also want to match .dll, .bat, .exe files
    foreach my $f (@candfiles) {
      &TeXLive::TLUtils::debug("matching $f in $dirpart via glob $globline.{bat/exe}");
      if ($f =~ /^$basepart\.(bat|exe|dll)$/) {
        &TeXLive::TLUtils::debug("hit: globline=$globline, $dirpart/$f");
        push @returnfiles, "$dirpart/$f";
      }
    }
  }
  return(@returnfiles);
}

sub _get_files_matching_regexp_pattern {
  my $self = shift;
  my ($type,$regexp) = @_;
  my @returnfiles;
  FILELABEL: foreach my $f (keys(%{$self->{'_allfiles'}})) {
    if ($f =~ /^$regexp$/) {
      TeXLive::TLUtils::push_uniq(\@returnfiles,$f);
      next FILELABEL;
    }
  }
  return(@returnfiles);
}

sub _get_files_matching_dir_pattern {
  my ($self,$type,@patwords) = @_;
  my $tl = pop @patwords;
  my @returnfiles;
  if (defined($self->{'_dirnames'}{$tl})) {
    foreach my $tld (@{$self->{'_dirnames'}{$tl}}) {
      if (index($tld,join("/",@patwords)."/") == 0) {
        my @files = $self->files_under_path($tld);
        TeXLive::TLUtils::push_uniq(\@returnfiles, @files);
      }
    }
  }
  return(@returnfiles);
}

sub files_under_path {
  my $self = shift;
  my $p = shift;
  my @files = ();
  foreach my $aa (@{$self->{'_filesofdir'}{$p}}) {
    TeXLive::TLUtils::push_uniq(\@files, $p . "/" . $aa);
  }
  if (defined($self->{'_subdirsofdir'}{$p})) {
    foreach my $sd (@{$self->{'_subdirsofdir'}{$p}}) {
      my @sdf = $self->files_under_path($p . "/" . $sd);
      TeXLive::TLUtils::push_uniq (\@files, @sdf);
    }
  }
  return @files;
}


#
# member access functions
#
sub svnroot {
  my $self = shift;
  if (@_) { $self->{'svnroot'} = shift };
  return $self->{'svnroot'};
}

sub architectures {
  my $self = shift;
  if (@_) { @{ $self->{'archs'} } = @_ }
  return exists $self->{'archs'} ? @{ $self->{'archs'} } : undef;
}


1;

### Local Variables:
### perl-indent-level: 2
### tab-width: 2
### indent-tabs-mode: nil
### End:
# vim:set tabstop=2 expandtab: #