diff options
Diffstat (limited to 'new-infra/tlsrc2tlp.pl')
-rw-r--r-- | new-infra/tlsrc2tlp.pl | 361 |
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 = |