#!/usr/bin/env perl -w # # tlsrc2tlp.pl # generate tlp files from tlsrc files # Copyright 2007 Norbert Preining # # This file is licensed under the GNU General Public Licence version 2 # or any later version use strict; 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 { my (@tlsrc) = @_; foreach my $f (@tlsrc) { read_tlsrc_file($f); } initialize_all_files(); my $ts = $#tlsrc + 1; my $fs = 0; $| = 1; foreach my $f (keys %tls) { print "."; $fs++; 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) { @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"; } } } sub read_tlsrc_file { my ($tlsrc) = @_; open(TMP,"<$tlsrc") || die("Cannot open $tlsrc: $!"); my @lines = ; close(TMP); my $name = ""; my $shortdesc = ""; my $longdesc= ""; my $catalogue = ""; my (@executes, @depends); my (@runpatterns, @docpatterns, @binpatterns, @srcpatterns); my $started = 0; my $finished = 0; my $lastcmd = ""; logit("Working on $tlsrc\n"); foreach my $line (@lines) { $line =~ /^\s*#/ && next; # skip comment lines if ($line =~ /^\s*$/) { if (!$started) { next; } if ($finished) { next; } die("No empty line allowed in tlsrc files!"); } if ($line =~ /^ /) { if ( ($lastcmd eq "longdesc") || ($lastcmd eq "runpattern") || ($lastcmd eq "binpattern") || ($lastcmd eq "docpattern") || ($lastcmd eq "srcpattern") || ($lastcmd eq "execute") || ($lastcmd eq "depend") ) { $line =~ s/^ /$lastcmd /; } else { die("Continuation of $lastcmd not allowed, please fix tlsrc!\n"); } } if ($line =~ /^name\s*([\w-]+)$/) { logit("found name: $1\n"); $name = "$1"; $lastcmd = "name"; $started && die("Cannot have two name directives!"); $started = 1; } else { $started || die("First directive needs to be 'name'"); if ($line =~ /^shortdesc\s*(.*)$/) { logit("found shortdesc: $1\n"); $shortdesc .= "$1 "; $lastcmd = "shortdesc"; next; } elsif ($line =~ /^longdesc\s*(.*)$/) { logit("found longdesc: $1\n"); $longdesc .= "$1 "; $lastcmd = "longdesc"; next; } elsif ($line =~ /^catalogue\s*(.*)$/) { logit("found catalogue: $1\n"); $catalogue .= "$1 "; $lastcmd = "catalogue"; next; } elsif ($line =~ /^runpattern\s*(.*)$/) { logit("found runpattern: $1\n"); push @runpatterns, "$1"; $lastcmd = "runpattern"; next; } elsif ($line =~ /^srcpattern\s*(.*)$/) { logit("found srcpattern: $1\n"); push @srcpatterns, "$1"; $lastcmd = "srcpattern"; next; } elsif ($line =~ /^docpattern\s*(.*)$/) { logit("found docpattern: $1\n"); push @docpatterns, "$1"; $lastcmd = "docpattern"; next; } elsif ($line =~ /^binpattern\s*(.*)$/) { logit("found binpattern: $1\n"); push @binpatterns, "$1"; $lastcmd = "binpattern"; next; } elsif ($line =~ /^execute\s*(.*)$/) { logit("found execute: $1\n"); push @executes, "$1"; $lastcmd = "execute"; next; } elsif ($line =~ /^depend\s*(.*)$/) { logit("found depend: $1\n"); push @depends, "$1"; $lastcmd = "depend"; next; } else { die("Unknown directive ...$line... in $tlsrc, please fix it!"); } } } logit("Done reading the source file, filling the data structure!\n"); if ($catalogue ne "") { $tls{$name}{'catalogue'} = "$catalogue"; } else { $tls{$name}{'catalogue'} = "$name"; } if ($shortdesc ne "") { $tls{$name}{'shortdesc'} = "$shortdesc"; } if ($longdesc ne "") { $tls{$name}{'longdesc'} = "$longdesc"; } if ($#srcpatterns >= 0) { $tls{$name}{'srcpatterns'} = [ @srcpatterns ]; } if ($#runpatterns >= 0) { $tls{$name}{'runpatterns'} = [ @runpatterns ]; } if ($#binpatterns >= 0) { $tls{$name}{'binpatterns'} = [ @binpatterns ]; } if ($#docpatterns >= 0) { $tls{$name}{'docpatterns'} = [ @docpatterns ]; } if ($#executes >= 0) { $tls{$name}{'executes'} = [ @executes ]; } if ($#depends>= 0) { $tls{$name}{'depends'} = [ @depends ]; } } sub initialize_all_files { my @lines; if (-r "$statusfile") { logit("Reading svn status from $statusfile\n"); open(FOO,"$statusfile") || die("Cannot open statusfile $statusfile"); @lines = ; 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; # 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; } } sub generate_tlp_data { my ($tlp) = @_; # 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'})) { $tldb{$tlp}{'shortdesc'} = $tls{$tlp}{'shortdesc'}; } if (defined($tls{$tlp}{'longdesc'})) { $tldb{$tlp}{'longdesc'} = $tls{$tlp}{'longdesc'}; } if (defined($tls{$tlp}{'catalogue'})) { $tldb{$tlp}{'catalogue'} = $tls{$tlp}{'catalogue'}; } if (defined($tls{$tlp}{'executes'})) { $tldb{$tlp}{'executes'} = $tls{$tlp}{'executes'}; } if (defined($tls{$tlp}{'depends'})) { $tldb{$tlp}{'depends'} = $tls{$tlp}{'depends'}; } $tldb{$tlp}{'runfiles'} = [ ]; $tldb{$tlp}{'docfiles'} = [ ]; $tldb{$tlp}{'binfiles'} = [ ]; $tldb{$tlp}{'srcfiles'} = [ ]; $tldb{$tlp}{'packageversion'} = 0; my $filemax; 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}{'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}{'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}{'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"; #### 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; } if (defined($tldb{$tlp}{'longdesc'})) { $tlpline = "longdesc $tldb{$tlp}{'longdesc'}"; write TLP; } if (defined($tldb{$tlp}{'catalogue'})) { #######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 (sort @tmp) { print TLP " $_\n"; } } @tmp = @{$tldb{$tlp}{'srcfiles'}}; if ($#tmp >= 0) { print TLP "srcfiles\n"; foreach (sort @tmp) { print TLP " $_\n"; } } @tmp = @{$tldb{$tlp}{'binfiles'}}; if ($#tmp >= 0) { print TLP "binfiles\n"; foreach (sort @tmp) { print TLP " $_\n"; } } @tmp = @{$tldb{$tlp}{'runfiles'}}; if ($#tmp >= 0) { print TLP "runfiles\n"; foreach (sort @tmp) { print TLP " $_\n"; } } close(TLP); } sub logit { $opt_debug && print STDERR @_; } 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 member { my ($e, @l) = @_; my ($f); foreach $f (@l) { if ($e eq $f) { return 1; } } return 0; } sub push_uniq { my ($l,@le) = @_; my ($e); foreach $e (@le) { if (! &member($e, @$l)) { push @$l, $e; } } } ###### Formats format TLP = ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< $tlpline ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<~~ $tlpline . ### Local Variables: ### perl-indent-level: 4 ### tab-width: 4 ### indent-tabs-mode: t ### End: # vim:set tabstop=4: #