summaryrefslogtreecommitdiff
path: root/new-infra/tlsrc2tlp.pl
diff options
context:
space:
mode:
Diffstat (limited to 'new-infra/tlsrc2tlp.pl')
-rw-r--r--new-infra/tlsrc2tlp.pl361
1 files changed, 271 insertions, 90 deletions
diff --git a/new-infra/tlsrc2tlp.pl b/new-infra/tlsrc2tlp.pl
index 101d20d2146..f05210226eb 100644
--- a/new-infra/tlsrc2tlp.pl
+++ b/new-infra/tlsrc2tlp.pl
@@ -13,14 +13,36 @@ my %tls;
my %tldb;
my $opt_debug = 0;
my %AllFiles;
+my %DirNames;
+my %FilesOfDir;
+my %SubdirsOfDir;
+my $statusfile = "";
my $tlpline;
+my $DirTree = { };
+
+use Getopt::Long;
+GetOptions("debug!" => \$opt_debug, "statusfile=s" => \$statusfile);
+
&main(@ARGV);
1;
+sub dirname {
+ my ($f) = @_;
+ if ($f =~ m@(^.*)[\\/][^\\/]*$@) {
+ return $1;
+ } else {
+ return ".";
+ }
+}
+sub basename {
+ my ($f) = @_;
+ $f =~ m@([^\\/]*)$@;
+ return $1;
+}
sub main {
@@ -31,18 +53,34 @@ sub main {
initialize_all_files();
my $ts = $#tlsrc + 1;
my $fs = 0;
+ $| = 1;
foreach my $f (keys %tls) {
+ print ".";
$fs++;
- if ($fs/10 == int($fs/10)) { print "$fs from $ts\n"; }
+ if ($fs/100 == int($fs/100)) { print "$fs from $ts\n"; }
generate_tlp_data($f);
write_tlp_file($f);
}
#foreach my $f (keys %tldb) {
# write_tlp_file($f);
#}
+ my @notused = ();
+ my @multiused = ();
+ my @tmp;
foreach my $f (keys %AllFiles) {
- if ($AllFiles{$f}{'used'} != 1) {
- print STDERR "Not covered file: $f\n";
+ @tmp = @{$AllFiles{$f}{'used'}};
+ if ($#tmp < 0) { push @notused, $f; }
+ if ($#tmp >= 1) { push @multiused, $f; }
+ }
+ if ($#notused >= 0) { print "NOT COVERED FILES:\n"; }
+ foreach my $f (sort @notused) {
+ print STDERR "$f\n";
+ }
+ if ($#multiused >= 0) { print "MULTIPLE INCLUDED FILES:\n"; }
+ foreach my $f (sort @multiused) {
+ print STDERR "$f\n";
+ foreach (@{$AllFiles{$f}{'used'}}) {
+ print " $_\n";
}
}
}
@@ -174,45 +212,101 @@ sub read_tlsrc_file {
}
sub initialize_all_files {
- foreach my $l (`svn status -v`) {
+ my @lines;
+ if (-r "$statusfile") {
+ logit("Reading svn status from $statusfile\n");
+ open(FOO,"$statusfile") || die("Cannot open statusfile $statusfile");
+ @lines = <FOO>;
+ close(FOO);
+ } else {
+ logit("Reading svn status from svn status -v\n");
+ @lines = `svn status -v`;
+ }
+ 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;
my $entry = "$9";
- next if -d $entry;
- $AllFiles{$entry}{'used'} = 0;
+ next if -d $entry; # TODO: what to do with links???
+ @{$AllFiles{$entry}{'used'}} = ();
$AllFiles{$entry}{'lastchangedrev'} = $lastchanged;
+ my $fn = basename($entry);
+ my $dn = dirname($entry);
+ add_path_to_tree($DirTree, split("[/\\\\]", $dn));
+ push @{$FilesOfDir{$dn}}, $fn;
} else {
die("Cannot read svn status output line: $l");
}
}
+ # now do some magic
+ # - create list of top level dirs with a list of full path names of
+ # the respective dir attached
+ # MISSING
+ #print_tree($DirTree);
+ walk_tree($DirTree, \&find_alldirs);
+}
+
+sub print_tree {
+ my ($node) = @_;
+ &walk_tree($node, \&print_node);
+}
+
+sub find_alldirs {
+ my ($node, @stackdir) = @_;
+ my $tl = $stackdir[-1];
+ push @{$DirNames{$tl}}, join("/", @stackdir);
+ if (keys(%{$node})) {
+ my $pa = join("/", @stackdir);
+ push @{$SubdirsOfDir{$pa}}, keys(%{$node});
+ }
+}
+
+sub print_node {
+ my ($node, @stackdir) = @_;
+ my $dp = join("/", @stackdir);
+ if ($FilesOfDir{$dp}) {
+ foreach my $f (@{$FilesOfDir{$dp}}) {
+ print "dp=$dp file=$f\n";
+ }
+ }
+ if (! keys(%{$node})) {
+ print join("/", @stackdir) . "\n";
+ }
+}
+
+sub walk_tree {
+ my (@stack_dir);
+ walk_tree1(@_, @stack_dir);
+}
+
+sub walk_tree1 {
+ 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}($v, @stack_dir) }
+ walk_tree1 (\%{$v}, $pre_proc, $post_proc, @stack_dir);
+ $v = $node->{$k};
+ if ($post_proc) { &{$post_proc}($v, @stack_dir) }
+ pop @stack_dir;
+ }
}
-#
-# possible optimizations:
-# - compile perl regexps once at the beginning before entering the big loop
-# in the loop mega action
-#
sub generate_tlp_data {
my ($tlp) = @_;
- # predefined runpattern if all are missing
- # WARNING
- # Note that this will NOT NOT NOT find files in leaf directories named
- # after the package but OUTSIDE texmf-dist, so files in
- # texmf-doc/..../packagename/
- # will NOT be found.
- if (!(defined($tls{$tlp}{'runpatterns'}))) {
- my $l = "d texmf-dist/(bibtex|context|dvips|fonts|makeindex|metafont|metapost|mft|omega|scripts|tex|tex4ht|vtex)/.*/$tlp";
- @{$tls{$tlp}{'runpatterns'}} = ("$l");
- }
- if (!(defined($tls{$tlp}{'docpatterns'}))) {
- my $l = "d texmf-dist/doc/.*/$tlp";
- @{$tls{$tlp}{'docpatterns'}} = ("$l");
- }
- if (!(defined($tls{$tlp}{'srcpatterns'}))) {
- my $l = "d texmf-dist/source/.*/$tlp";
- @{$tls{$tlp}{'srcpatterns'}} = ("$l");
+ # predefined patterns if all are missing
+ if (! ( (defined($tls{$tlp}{'runpatterns'})) ||
+ (defined($tls{$tlp}{'srcpatterns'})) ||
+ (defined($tls{$tlp}{'docpatterns'})) ||
+ (defined($tls{$tlp}{'binpatterns'})) )) {
+ foreach my $md (qw/bibtex context dvips fonts makeindex metafont
+ metapost mft omega scripts tex vtex/) {
+ push @{$tls{$tlp}{'runpatterns'}}, "t texmf-dist $md $tlp";
+ }
+ push @{$tls{$tlp}{'docpatterns'}}, "t texmf-dist doc $tlp";
+ push @{$tls{$tlp}{'srcpatterns'}}, "t texmf-dist source $tlp";
}
$tldb{$tlp}{'name'} = $tls{$tlp};
if (defined($tls{$tlp}{'shortdesc'})) {
@@ -236,52 +330,126 @@ sub generate_tlp_data {
$tldb{$tlp}{'srcfiles'} = [ ];
$tldb{$tlp}{'packageversion'} = 0;
my $filemax;
- FILELABEL: foreach my $f (keys %AllFiles) {
- $filemax = $AllFiles{$f}{'lastchangedrev'};
- foreach my $p (@{$tls{$tlp}{'runpatterns'}}) {
- if (pattern_hit($f,$p,"run")) {
- $AllFiles{$f}{'used'} = 1;
- logit("Hit\n");
- $tldb{$tlp}{'packageversion'} = $filemax > $tldb{$tlp}{'packageversion'} ? $filemax : $tldb{$tlp}{'packageversion'};
- $tldb{$tlp}{'runfiles'} = [ @{$tldb{$tlp}{'runfiles'}}, $f ];
- next FILELABEL;
- }
+ foreach my $p (@{$tls{$tlp}{'runpatterns'}}) {
+ my ($pattype,@patwords) = split ' ',$p;
+ if ($pattype eq "t") {
+ do_leaf_pattern($tlp,'runfiles',@patwords);
+ } else {
+ do_regexp_pattern($tlp,'runfiles',$p);
}
- foreach my $p (@{$tls{$tlp}{'docpatterns'}}) {
- if (pattern_hit($f,$p,"doc")) {
- $AllFiles{$f}{'used'} = 1;
- logit("Hit\n");
- $tldb{$tlp}{'packageversion'} = $filemax > $tldb{$tlp}{'packageversion'} ? $filemax : $tldb{$tlp}{'packageversion'};
- $tldb{$tlp}{'docfiles'} = [ @{$tldb{$tlp}{'docfiles'}}, $f ];
- next FILELABEL;
- }
+ }
+ foreach my $p (@{$tls{$tlp}{'srcpatterns'}}) {
+ my ($pattype,@patwords) = split ' ',$p;
+ if ($pattype eq "t") {
+ do_leaf_pattern($tlp,'srcfiles',@patwords);
+ } else {
+ do_regexp_pattern($tlp,'srcfiles',$p);
}
- foreach my $p (@{$tls{$tlp}{'binpatterns'}}) {
- if (pattern_hit($f,$p,"bin")) {
- $AllFiles{$f}{'used'} = 1;
- logit("Hit\n");
- $tldb{$tlp}{'packageversion'} = $filemax > $tldb{$tlp}{'packageversion'} ? $filemax : $tldb{$tlp}{'packageversion'};
- $tldb{$tlp}{'binfiles'} = [ @{$tldb{$tlp}{'binfiles'}}, $f ];
- next FILELABEL;
- }
+ }
+ foreach my $p (@{$tls{$tlp}{'docpatterns'}}) {
+ my ($pattype,@patwords) = split ' ',$p;
+ if ($pattype eq "t") {
+ do_leaf_pattern($tlp,'docfiles',@patwords);
+ } else {
+ do_regexp_pattern($tlp,'docfiles',$p);
}
- foreach my $p (@{$tls{$tlp}{'srcpatterns'}}) {
- if (pattern_hit($f,$p,"src")) {
- $AllFiles{$f}{'used'} = 1;
- logit("Hit\n");
- $tldb{$tlp}{'packageversion'} = $filemax > $tldb{$tlp}{'packageversion'} ? $filemax : $tldb{$tlp}{'packageversion'};
- $tldb{$tlp}{'srcfiles'} = [ @{$tldb{$tlp}{'srcfiles'}}, $f ];
- next FILELABEL;
+ }
+ foreach my $p (@{$tls{$tlp}{'binpatterns'}}) {
+ my ($pattype,@patwords) = split ' ',$p;
+ if ($pattype eq "t") {
+ do_leaf_pattern($tlp,'binfiles',@patwords);
+ } else {
+ do_regexp_pattern($tlp,'binfiles',$p);
+ }
+ }
+}
+
+sub do_leaf_pattern {
+ my ($tlp,$type,@patwords) = @_;
+ # the pattern type looks like: dir1 dir2 ... dirn dirtl
+ # where a file matches if it looks like
+ # dir1/dir2/.../dirn/.*/dirtl/file
+ # all but the first define the first dirs, the last the leaf dir
+ my $tl = pop @patwords;
+ my $filemax;
+ if (defined($DirNames{$tl})) {
+ foreach my $tld (@{$DirNames{$tl}}) {
+ if (index($tld,join("/",@patwords)."/") == 0) {
+ my @files = files_under_path($tld);
+ foreach my $f (@files) {
+ $filemax = $AllFiles{$f}{'lastchangedrev'};
+ push_uniq( \@{$AllFiles{$f}{'used'}}, $tlp );
+ $tldb{$tlp}{'packageversion'} = $filemax > $tldb{$tlp}{'packageversion'} ? $filemax : $tldb{$tlp}{'packageversion'};
+ }
+ push_uniq (\@{$tldb{$tlp}{$type}}, @files);
+ #$tldb{$tlp}{$type} = [ @{$tldb{$tlp}{$type}}, @files ];
}
}
}
}
+sub files_under_path {
+ my ($p) = @_;
+ my @files = ();
+ foreach my $aa (@{$FilesOfDir{$p}}) {
+ push_uniq( \@files, $p . "/" . $aa);
+ }
+ if (defined($SubdirsOfDir{$p})) {
+ foreach my $sd (@{$SubdirsOfDir{$p}}) {
+ my @sdf = files_under_path($p . "/" . $sd);
+ push_uniq (\@files, @sdf);
+ }
+ }
+ return @files;
+}
+
+sub do_regexp_pattern {
+ my ($tlp,$filetype,$p) = @_;
+ my $filemax;
+ FILELABEL: foreach my $f (keys %AllFiles) {
+ $filemax = $AllFiles{$f}{'lastchangedrev'};
+ if (pattern_hit($f,$p)) {
+ push_uniq( \@{$AllFiles{$f}{'used'}}, $tlp );
+ logit("Hit\n");
+ $tldb{$tlp}{'packageversion'} = $filemax > $tldb{$tlp}{'packageversion'} ? $filemax : $tldb{$tlp}{'packageversion'};
+ $tldb{$tlp}{$filetype} = [ @{$tldb{$tlp}{$filetype}}, $f ];
+ next FILELABEL;
+ }
+ }
+}
+
+sub pattern_hit {
+ my ($file, $pattern) = @_;
+ my (@dirs) = split /\//, $file;
+ $pattern =~ /^(d|f|t)\s+(.*)$/;
+ my $pattype = $1;
+ my $patdata = $2;
+ logit("pattype=...$pattype...patdata=...$patdata...\n");
+ if ($pattype eq "d") {
+ pop @dirs ;
+ my $foo = join "/",@dirs;
+ logit("matching [d] >>>$patdata<<< against >>>$foo<<<\n");
+ if ($foo =~ /^$patdata$/) {
+ return 1;
+ }
+ } elsif ($pattype eq "f") {
+ logit("matching [f] >>>$patdata<<< against >>>$file<<<\n");
+ if ($file =~ /^$patdata$/) {
+ return 1;
+ }
+ } else {
+ die("Unknown pattern specification: $pattern!");
+ }
+ return 0;
+}
+
+
sub write_tlp_file {
my ($tlp) = @_;
open(TLP,">tlp/$tlp.tlp") || die("Cannot open tlp/$tlp.tlp for writing: $!");
print TLP "name $tlp\n";
- print TLP "packageversion $tldb{$tlp}{'packageversion'}\n";
+ #### these two things are disabled for comparison reasons
+ #####print TLP "packageversion $tldb{$tlp}{'packageversion'}\n";
if (defined($tldb{$tlp}{'shortdesc'})) {
$tlpline = "shortdesc $tldb{$tlp}{'shortdesc'}";
write TLP;
@@ -291,44 +459,44 @@ sub write_tlp_file {
write TLP;
}
if (defined($tldb{$tlp}{'catalogue'})) {
- print TLP "catalogue $tldb{$tlp}{'catalogue'}\n";
- }
- if (defined($tldb{$tlp}{'executes'})) {
- foreach (@{$tldb{$tlp}{'executes'}}) {
- print TLP "execute $_\n";
- }
+ #######print TLP "catalogue $tldb{$tlp}{'catalogue'}\n";
}
if (defined($tldb{$tlp}{'depends'})) {
foreach (@{$tldb{$tlp}{'depends'}}) {
print TLP "depend $_\n";
}
}
+ if (defined($tldb{$tlp}{'executes'})) {
+ foreach (@{$tldb{$tlp}{'executes'}}) {
+ print TLP "execute $_\n";
+ }
+ }
my @tmp;
@tmp = @{$tldb{$tlp}{'docfiles'}};
if ($#tmp >= 0) {
print TLP "docfiles\n";
- foreach (@tmp) {
+ foreach (sort @tmp) {
print TLP " $_\n";
}
}
@tmp = @{$tldb{$tlp}{'srcfiles'}};
if ($#tmp >= 0) {
print TLP "srcfiles\n";
- foreach (@tmp) {
+ foreach (sort @tmp) {
print TLP " $_\n";
}
}
@tmp = @{$tldb{$tlp}{'binfiles'}};
if ($#tmp >= 0) {
print TLP "binfiles\n";
- foreach (@tmp) {
+ foreach (sort @tmp) {
print TLP " $_\n";
}
}
@tmp = @{$tldb{$tlp}{'runfiles'}};
if ($#tmp >= 0) {
print TLP "runfiles\n";
- foreach (@tmp) {
+ foreach (sort @tmp) {
print TLP " $_\n";
}
}
@@ -339,30 +507,43 @@ sub logit {
$opt_debug && print STDERR @_;
}
-sub pattern_hit {
- my ($file, $pattern, $patterntype) = @_;
- $pattern =~ /^(d|f) (.*)$/;
- my $pattype = $1;
- my $patdata = $2;
- if ($pattype eq "d") {
- #my $dirn = `dirname $file`; # bad, should be rewritten
- #chomp($dirn);
- my $dirn = $file;
- $dirn =~ s@/[^/]*$@@;
- logit("matching >>>$patdata<<< against >>>$dirn<<<\n");
- if ($dirn =~ /^$patdata$/) {
- return 1;
+
+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};
}
- } elsif ($pattype eq "f") {
- logit("matching >>>$patdata<<< against >>>$file<<<\n");
- if ($file =~ /^$patdata$/) {
+ }
+ return $node;
+}
+
+sub member {
+ my ($e, @l) = @_;
+ my ($f);
+ foreach $f (@l) {
+ if ($e eq $f) {
return 1;
}
- } else {
- die("Unknown pattern specification: $pattern!");
}
+ return 0;
}
+sub push_uniq {
+ my ($l,@le) = @_;
+ my ($e);
+ foreach $e (@le) {
+ if (! &member($e, @$l)) {
+ push @$l, $e;
+ }
+ }
+}
###### Formats
format TLP =